ghc/compiler/stgSyn/CoreToStg.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 %************************************************************************
   5 %*                                                                      *
   6 \section[CoreToStg]{Converting core syntax to STG syntax}
   7 %*                                                                      *
   8 %************************************************************************
   9
  10 Convert a @CoreSyntax@ program to a @StgSyntax@ program.
  11
  12 \begin{code}
  13 module CoreToStg ( topCoreBindsToStg ) where
  14
  15 #include "HsVersions.h"
  16
  17 import CoreSyn          -- input
  18 import StgSyn           -- output
  19
  20 import CoreUtils        ( coreExprType )
  21 import SimplUtils       ( findDefault )
  22 import CostCentre       ( noCCS )
  23 import Id               ( Id, mkSysLocal, idType,
  24                           externallyVisibleId, setIdUnique, idName, getIdDemandInfo
  25                         )
  26 import Var              ( Var, varType, modifyIdInfo )
  27 import IdInfo           ( setDemandInfo )
  28 import UsageSPUtils     ( primOpUsgTys )
  29 import DataCon          ( DataCon, dataConName, dataConId )
  30 import Name             ( Name, nameModule, isLocallyDefinedName )
  31 import Module           ( isDynamicModule )
  32 import Const            ( Con(..), Literal, isLitLitLit )
  33 import VarEnv
  34 import Const            ( Con(..), isWHNFCon, Literal(..) )
  35 import PrimOp           ( PrimOp(..), primOpUsg )
  36 import Type             ( isUnLiftedType, isUnboxedTupleType, Type, splitFunTy_maybe,
  37                           UsageAnn(..), tyUsg, applyTy )
  38 import TysPrim          ( intPrimTy )
  39 import Demand
  40 import Unique           ( Unique, Uniquable(..) )
  41 import UniqSupply       -- all of it, really
  42 import Util
  43 import Maybes
  44 import Outputable
  45 \end{code}
  46
  47
  48         ***************  OVERVIEW   *********************
  49
  50
  51 The business of this pass is to convert Core to Stg.  On the way:
  52
  53 * We discard type lambdas and applications. In so doing we discard
  54   "trivial" bindings such as
  55         x = y t1 t2
  56   where t1, t2 are types
  57
  58 * We don't pin on correct arities any more, because they can be mucked up
  59   by the lambda lifter.  In particular, the lambda lifter can take a local
  60   letrec-bound variable and make it a lambda argument, which shouldn't have
  61   an arity.  So SetStgVarInfo sets arities now.
  62
  63 * We do *not* pin on the correct free/live var info; that's done later.
  64   Instead we use bOGUS_LVS and _FVS as a placeholder.
  65
  66 [Quite a bit of stuff that used to be here has moved
  67  to tidyCorePgm (SimplCore.lhs) SLPJ Nov 96]
  68
  69
  70 %************************************************************************
  71 %*                                                                      *
  72 \subsection[coreToStg-programs]{Converting a core program and core bindings}
  73 %*                                                                      *
  74 %************************************************************************
  75
  76 March 98: We keep a small environment to give all locally bound
  77 Names new unique ids, since the code generator assumes that binders
  78 are unique across a module. (Simplifier doesn't maintain this
  79 invariant any longer.)
  80
  81 A binder to be floated out becomes an @StgFloatBind@.
  82
  83 \begin{code}
  84 type StgEnv = IdEnv Id
  85
  86 data StgFloatBind = StgFloatBind Id StgExpr RhsDemand
  87 \end{code}
  88
  89 A @RhsDemand@ gives the demand on an RHS: strict (@isStrictDem@) and
  90 thus case-bound, or if let-bound, at most once (@isOnceDem@) or
  91 otherwise.
  92
  93 \begin{code}
  94 data RhsDemand  = RhsDemand { isStrictDem :: Bool,  -- True => used at least once
  95                               isOnceDem   :: Bool   -- True => used at most once
  96                             }
  97
  98 tyDem :: Type -> RhsDemand
  99 -- derive RhsDemand (assuming let-binding)
 100 tyDem ty = case tyUsg ty of
 101              UsOnce  -> RhsDemand False True
 102              UsMany  -> RhsDemand False False
 103              UsVar _ -> pprPanic "CoreToStg.tyDem: UsVar unexpected:" $ ppr ty
 104
 105 bdrDem :: Var -> RhsDemand
 106 bdrDem = tyDem . varType
 107
 108 safeDem, onceDem :: RhsDemand
 109 safeDem = RhsDemand False False  -- always safe to use this
 110 onceDem = RhsDemand False True   -- used at most once
 111 \end{code}
 112
 113 No free/live variable information is pinned on in this pass; it's added
 114 later.  For this pass
 115 we use @bOGUS_LVs@ and @bOGUS_FVs@ as placeholders.
 116
 117 \begin{code}
 118 bOGUS_LVs :: StgLiveVars
 119 bOGUS_LVs = panic "bOGUS_LVs" -- emptyUniqSet (used when pprTracing)
 120
 121 bOGUS_FVs :: [Id]
 122 bOGUS_FVs = panic "bOGUS_FVs" -- [] (ditto)
 123 \end{code}
 124
 125 \begin{code}
 126 topCoreBindsToStg :: UniqSupply -- name supply
 127                   -> [CoreBind] -- input
 128                   -> [StgBinding]       -- output
 129
 130 topCoreBindsToStg us core_binds
 131   = initUs_ us (coreBindsToStg emptyVarEnv core_binds)
 132   where
 133     coreBindsToStg :: StgEnv -> [CoreBind] -> UniqSM [StgBinding]
 134
 135     coreBindsToStg env [] = returnUs []
 136     coreBindsToStg env (b:bs)
 137       = coreBindToStg  env b            `thenUs` \ (new_b, new_env) ->
 138         coreBindsToStg new_env bs       `thenUs` \ new_bs ->
 139         returnUs (new_b ++ new_bs)
 140 \end{code}
 141
 142 %************************************************************************
 143 %*                                                                      *
 144 \subsection[coreToStg-binds]{Converting bindings}
 145 %*                                                                      *
 146 %************************************************************************
 147
 148 \begin{code}
 149 coreBindToStg :: StgEnv
 150               -> CoreBind
 151               -> UniqSM ([StgBinding],  -- Empty or singleton
 152                          StgEnv)        -- Floats
 153
 154 coreBindToStg env (NonRec binder rhs)
 155   = coreRhsToStg env rhs (bdrDem binder) `thenUs` \ stg_rhs ->
 156     newLocalId env binder                `thenUs` \ (new_env, new_binder) ->
 157     returnUs ([StgNonRec new_binder stg_rhs], new_env)
 158
 159 coreBindToStg env (Rec pairs)
 160   = newLocalIds env binders              `thenUs` \ (env', binders') ->
 161     mapUs (\ (bdr,rhs) -> coreRhsToStg env' rhs (bdrDem bdr) )
 162           pairs                          `thenUs` \ stg_rhss ->
 163     returnUs ([StgRec (binders' `zip` stg_rhss)], env')
 164   where
 165     (binders, rhss) = unzip pairs
 166 \end{code}
 167
 168
 169 %************************************************************************
 170 %*                                                                      *
 171 \subsection[coreToStg-rhss]{Converting right hand sides}
 172 %*                                                                      *
 173 %************************************************************************
 174
 175 \begin{code}
 176 coreRhsToStg :: StgEnv -> CoreExpr -> RhsDemand -> UniqSM StgRhs
 177
 178 coreRhsToStg env core_rhs dem
 179   = coreExprToStg env core_rhs dem  `thenUs` \ stg_expr ->
 180     returnUs (exprToRhs dem stg_expr)
 181
 182 exprToRhs dem (StgLet (StgNonRec var1 rhs) (StgApp var2 []))
 183   | var1 == var2
 184   = rhs
 185         -- This curious stuff is to unravel what a lambda turns into
 186         -- We have to do it this way, rather than spot a lambda in the
 187         -- incoming rhs.  Why?  Because trivial bindings might conceal
 188         -- what the rhs is actually like.
 189
 190 {-
 191   We reject the following candidates for 'static constructor'dom:
 192
 193     - any dcon that takes a lit-lit as an arg.
 194     - [Win32 DLLs only]: any dcon that is (or takes as arg)
 195       that's living in a DLL.
 196
 197   These constraints are necessary to ensure that the code
 198   generated in the end for the static constructors, which
 199   live in the data segment, remain valid - i.e., it has to
 200   be constant. For obvious reasons, that's hard to guarantee
 201   with lit-lits. The second case of a constructor referring
 202   to static closures hiding out in some DLL is an artifact
 203   of the way Win32 DLLs handle global DLL variables. A (data)
 204   symbol exported from a DLL  has to be accessed through a
 205   level of indirection at the site of use, so whereas
 206
 207      extern StgClosure y_closure;
 208      extern StgClosure z_closure;
 209      x = { ..., &y_closure, &z_closure };
 210
 211   is legal when the symbols are in scope at link-time, it is
 212   not when y_closure is in a DLL. So, any potential static
 213   closures that refers to stuff that's residing in a DLL
 214   will be put in an (updateable) thunk instead.
 215
 216   An alternative strategy is to support the generation of
 217   constructors (ala C++ static class constructors) which will
 218   then be run at load time to fix up static closures.
 219 -}
 220 exprToRhs dem (StgCon (DataCon con) args _)
 221   | not is_dynamic  &&
 222     all  (not.is_lit_lit) args  = StgRhsCon noCCS con args
 223  where
 224   is_dynamic = isDynCon con || any (isDynArg) args
 225
 226   is_lit_lit (StgVarArg _) = False
 227   is_lit_lit (StgConArg x) =
 228      case x of
 229        Literal l -> isLitLitLit l
 230        _         -> False
 231
 232 exprToRhs dem expr
 233         = StgRhsClosure noCCS           -- No cost centre (ToDo?)
 234                         stgArgOcc       -- safe
 235                         noSRT           -- figure out later
 236                         bOGUS_FVs
 237                         (if isOnceDem dem then SingleEntry else Updatable)
 238                         []
 239                         expr
 240
 241 isDynCon :: DataCon -> Bool
 242 isDynCon con = isDynName (dataConName con)
 243
 244 isDynArg :: StgArg -> Bool
 245 isDynArg (StgVarArg v)   = isDynName (idName v)
 246 isDynArg (StgConArg con) =
 247   case con of
 248     DataCon dc -> isDynCon dc
 249     Literal l  -> isLitLitLit l
 250     _          -> False
 251
 252 isDynName :: Name -> Bool
 253 isDynName nm =
 254       not (isLocallyDefinedName nm) &&
 255       isDynamicModule (nameModule nm)
 256
 257
 258 \end{code}
 259
 260
 261 %************************************************************************
 262 %*                                                                      *
 263 \subsection[coreToStg-atoms{Converting atoms}
 264 %*                                                                      *
 265 %************************************************************************
 266
 267 \begin{code}
 268 coreArgsToStg :: StgEnv -> [(CoreArg,RhsDemand)] -> UniqSM ([StgFloatBind], [StgArg])
 269 -- arguments are all value arguments (tyargs already removed), paired with their demand
 270
 271 coreArgsToStg env []
 272   = returnUs ([], [])
 273
 274 coreArgsToStg env (ad:ads)
 275   = coreArgToStg env ad         `thenUs` \ (bs1, a') ->
 276     coreArgsToStg env ads       `thenUs` \ (bs2, as') ->
 277     returnUs (bs1 ++ bs2, a' : as')
 278
 279 -- This is where we arrange that a non-trivial argument is let-bound
 280
 281 coreArgToStg :: StgEnv -> (CoreArg,RhsDemand) -> UniqSM ([StgFloatBind], StgArg)
 282
 283 coreArgToStg env (arg,dem)
 284   = let
 285         ty   = coreExprType arg
 286         dem' = if isUnLiftedType ty  -- if it's unlifted, it's definitely strict
 287                then dem { isStrictDem = True }
 288                else dem
 289     in
 290     coreExprToStgFloat env arg dem'  `thenUs` \ (binds, arg') ->
 291     case (binds, arg') of
 292         ([], StgCon con [] _) | isWHNFCon con -> returnUs ([], StgConArg con)
 293         ([], StgApp v [])                     -> returnUs ([], StgVarArg v)
 294
 295         -- A non-trivial argument: we must let (or case-bind)
 296         -- We don't do the case part here... we leave that to mkStgBinds
 297
 298         -- Further complication: if we're converting this binding into
 299         -- a case,  then try to avoid generating any case-of-case
 300         -- expressions by pulling out the floats.
 301         (_, other) ->
 302                  newStgVar ty   `thenUs` \ v ->
 303                  if isStrictDem dem'
 304                    then returnUs (binds ++ [StgFloatBind v arg' dem'], StgVarArg v)
 305                    else returnUs ([StgFloatBind v (mkStgBinds binds arg') dem'], StgVarArg v)
 306 \end{code}
 307
 308
 309 %************************************************************************
 310 %*                                                                      *
 311 \subsection[coreToStg-exprs]{Converting core expressions}
 312 %*                                                                      *
 313 %************************************************************************
 314
 315 \begin{code}
 316 coreExprToStg :: StgEnv -> CoreExpr -> RhsDemand -> UniqSM StgExpr
 317
 318 coreExprToStg env (Var var) dem
 319   = returnUs (StgApp (stgLookup env var) [])
 320
 321 \end{code}
 322
 323 %************************************************************************
 324 %*                                                                      *
 325 \subsubsection[coreToStg-lambdas]{Lambda abstractions}
 326 %*                                                                      *
 327 %************************************************************************
 328
 329 \begin{code}
 330 coreExprToStg env expr@(Lam _ _) dem
 331   = let
 332         (binders, body) = collectBinders expr
 333         id_binders      = filter isId binders
 334         body_dem        = trace "coreExprToStg: approximating body_dem in Lam"
 335                           safeDem
 336     in
 337     newLocalIds env id_binders          `thenUs` \ (env', binders') ->
 338     coreExprToStg env' body body_dem    `thenUs` \ stg_body ->
 339
 340     if null id_binders then -- it was all type/usage binders; tossed
 341         returnUs stg_body
 342     else
 343     case stg_body of
 344
 345       -- if the body reduced to a lambda too...
 346       (StgLet (StgNonRec var (StgRhsClosure cc bi srt fvs uf args body))
 347               (StgApp var' []))
 348        | var == var' ->
 349         returnUs (StgLet (StgNonRec var
 350                             (StgRhsClosure noCCS
 351                                 stgArgOcc
 352                                 noSRT
 353                                 bOGUS_FVs
 354                                 ReEntrant
 355                                 (binders' ++ args)
 356                                 body))
 357                 (StgApp var []))
 358
 359       other ->
 360
 361         -- We must let-bind the lambda
 362         newStgVar (coreExprType expr)   `thenUs` \ var ->
 363         returnUs
 364           (StgLet (StgNonRec var (StgRhsClosure noCCS
 365                                   stgArgOcc
 366                                   noSRT
 367                                   bOGUS_FVs
 368                                   ReEntrant     -- binders is non-empty
 369                                   binders'
 370                                   stg_body))
 371            (StgApp var []))
 372 \end{code}
 373
 374 %************************************************************************
 375 %*                                                                      *
 376 \subsubsection[coreToStg-let(rec)]{Let and letrec expressions}
 377 %*                                                                      *
 378 %************************************************************************
 379
 380 \begin{code}
 381 coreExprToStg env (Let bind body) dem
 382   = coreBindToStg env     bind      `thenUs` \ (stg_binds, new_env) ->
 383     coreExprToStg new_env body dem  `thenUs` \ stg_body ->
 384     returnUs (foldr StgLet stg_body stg_binds)
 385 \end{code}
 386
 387
 388 %************************************************************************
 389 %*                                                                      *
 390 \subsubsection[coreToStg-scc]{SCC expressions}
 391 %*                                                                      *
 392 %************************************************************************
 393
 394 Covert core @scc@ expression directly to STG @scc@ expression.
 395 \begin{code}
 396 coreExprToStg env (Note (SCC cc) expr) dem
 397   = coreExprToStg env expr dem  `thenUs` \ stg_expr ->
 398     returnUs (StgSCC cc stg_expr)
 399 \end{code}
 400
 401 \begin{code}
 402 coreExprToStg env (Note other_note expr) dem = coreExprToStg env expr dem
 403 \end{code}
 404
 405 The rest are handled by coreExprStgFloat.
 406
 407 \begin{code}
 408 coreExprToStg env expr dem
 409   = coreExprToStgFloat env expr dem  `thenUs` \ (binds,stg_expr) ->
 410     returnUs (mkStgBinds binds stg_expr)
 411 \end{code}
 412
 413 %************************************************************************
 414 %*                                                                      *
 415 \subsubsection[coreToStg-applications]{Applications}
 416 %*                                                                      *
 417 %************************************************************************
 418
 419 \begin{code}
 420 coreExprToStgFloat env expr@(App _ _) dem
 421   = let
 422         (fun,rads,_) = collect_args expr
 423         ads          = reverse rads
 424     in
 425     coreArgsToStg env ads               `thenUs` \ (binds, stg_args) ->
 426
 427         -- Now deal with the function
 428     case (fun, stg_args) of
 429       (Var fun_id, _) ->        -- A function Id, so do an StgApp; it's ok if
 430                                 -- there are no arguments.
 431                             returnUs (binds,
 432                                    StgApp (stgLookup env fun_id) stg_args)
 433
 434       (non_var_fun, []) ->      -- No value args, so recurse into the function
 435                             ASSERT( null binds )
 436                             coreExprToStg env non_var_fun dem  `thenUs` \e ->
 437                             returnUs ([], e)
 438
 439       other ->  -- A non-variable applied to things; better let-bind it.
 440                 newStgVar (coreExprType fun)    `thenUs` \ fun_id ->
 441                 coreRhsToStg env fun onceDem    `thenUs` \ fun_rhs ->
 442                 returnUs (binds,
 443                           StgLet (StgNonRec fun_id fun_rhs) $
 444                           StgApp fun_id stg_args)
 445   where
 446         -- Collect arguments and demands (*in reverse order*)
 447     collect_args :: CoreExpr -> (CoreExpr, [(CoreExpr,RhsDemand)], Type)
 448     collect_args (App fun (Type tyarg)) = let (the_fun,ads,fun_ty) = collect_args fun
 449                                           in  (the_fun,ads,applyTy fun_ty tyarg)
 450     collect_args (App fun arg         ) = let (the_fun,ads,fun_ty) = collect_args fun
 451                                               (arg_ty,res_ty)      = expectJust "coreExprToStgFloat:collect_args" $
 452                                                                      splitFunTy_maybe fun_ty
 453                                           in  (the_fun,(arg,tyDem arg_ty):ads,res_ty)
 454     collect_args (Note (Coerce ty _) e) = let (the_fun,ads,_     ) = collect_args e
 455                                           in  (the_fun,ads,ty)
 456     collect_args (Note InlineCall    e) = collect_args e
 457     collect_args (Note (TermUsg _)   e) = collect_args e
 458     collect_args fun                    = (fun,[],coreExprType fun)
 459 \end{code}
 460
 461 %************************************************************************
 462 %*                                                                      *
 463 \subsubsection[coreToStg-con]{Constructors}
 464 %*                                                                      *
 465 %************************************************************************
 466
 467 For data constructors, the demand on an argument is the demand on the
 468 constructor as a whole (see module UsageSPInf).  For primops, the
 469 demand is derived from the type of the primop.
 470
 471 If usage inference is off, we simply make all bindings updatable for
 472 speed.
 473
 474 \begin{code}
 475 coreExprToStgFloat env expr@(Con con args) dem
 476   = let
 477         args'       = filter isValArg args
 478         dems'       = case con of
 479                         Literal _ -> ASSERT( null args' {-'cpp-} )
 480                                      []
 481                         DEFAULT   -> panic "coreExprToStgFloat: DEFAULT"
 482                         DataCon c -> repeat (if isOnceDem dem then onceDem else safeDem)
 483                         PrimOp  p -> let tyargs      = map (\ (Type ty) -> ty) $
 484                                                            takeWhile isTypeArg args
 485                                          (arg_tys,_) = primOpUsgTys p tyargs
 486                                      in  ASSERT( length arg_tys == length args' {-'cpp-} )
 487                                          -- primops always fully applied, so == not >=
 488                                          map tyDem arg_tys
 489     in
 490     coreArgsToStg env (zip args' dems')                  `thenUs` \ (binds, stg_atoms) ->
 491     (case con of  -- must change unique if present
 492        PrimOp (CCallOp (Right _) a b c) -> getUniqueUs   `thenUs` \ u ->
 493                                            returnUs (PrimOp (CCallOp (Right u) a b c))
 494        _                                -> returnUs con)
 495                                                          `thenUs` \ con' ->
 496     returnUs (binds, StgCon con' stg_atoms (coreExprType expr))
 497 \end{code}
 498
 499 %************************************************************************
 500 %*                                                                      *
 501 \subsubsection[coreToStg-cases]{Case expressions}
 502 %*                                                                      *
 503 %************************************************************************
 504
 505 \begin{code}
 506 coreExprToStgFloat env expr@(Case scrut bndr alts) dem
 507   = coreExprToStgFloat env scrut (bdrDem bndr)  `thenUs` \ (binds, scrut') ->
 508     newEvaldLocalId env bndr                    `thenUs` \ (env', bndr') ->
 509     alts_to_stg env' (findDefault alts)         `thenUs` \ alts' ->
 510     returnUs (binds, mkStgCase scrut' bndr' alts')
 511   where
 512     scrut_ty  = idType bndr
 513     prim_case = isUnLiftedType scrut_ty && not (isUnboxedTupleType scrut_ty)
 514
 515     alts_to_stg env (alts, deflt)
 516       | prim_case
 517       = default_to_stg env deflt                `thenUs` \ deflt' ->
 518         mapUs (prim_alt_to_stg env) alts        `thenUs` \ alts' ->
 519         returnUs (StgPrimAlts scrut_ty alts' deflt')
 520
 521       | otherwise
 522       = default_to_stg env deflt                `thenUs` \ deflt' ->
 523         mapUs (alg_alt_to_stg env) alts         `thenUs` \ alts' ->
 524         returnUs (StgAlgAlts scrut_ty alts' deflt')
 525
 526     alg_alt_to_stg env (DataCon con, bs, rhs)
 527           = coreExprToStg env rhs dem   `thenUs` \ stg_rhs ->
 528             returnUs (con, filter isId bs, [ True | b <- bs ]{-bogus use mask-}, stg_rhs)
 529                 -- NB the filter isId.  Some of the binders may be
 530                 -- existential type variables, which STG doesn't care about
 531
 532     prim_alt_to_stg env (Literal lit, args, rhs)
 533           = ASSERT( null args )
 534             coreExprToStg env rhs dem   `thenUs` \ stg_rhs ->
 535             returnUs (lit, stg_rhs)
 536
 537     default_to_stg env Nothing
 538       = returnUs StgNoDefault
 539
 540     default_to_stg env (Just rhs)
 541       = coreExprToStg env rhs dem   `thenUs` \ stg_rhs ->
 542         returnUs (StgBindDefault stg_rhs)
 543                 -- The binder is used for prim cases and not otherwise
 544                 -- (hack for old code gen)
 545 \end{code}
 546
 547 \begin{code}
 548 coreExprToStgFloat env expr@(Type _) dem
 549   = pprPanic "coreExprToStgFloat: tyarg unexpected:" $ ppr expr
 550 \end{code}
 551
 552 \begin{code}
 553 coreExprToStgFloat env expr dem
 554   = coreExprToStg env expr dem  `thenUs` \stg_expr ->
 555     returnUs ([], stg_expr)
 556 \end{code}
 557
 558 %************************************************************************
 559 %*                                                                      *
 560 \subsection[coreToStg-misc]{Miscellaneous helping functions}
 561 %*                                                                      *
 562 %************************************************************************
 563
 564 There's not anything interesting we can ASSERT about \tr{var} if it
 565 isn't in the StgEnv. (WDP 94/06)
 566
 567 \begin{code}
 568 stgLookup :: StgEnv -> Id -> Id
 569 stgLookup env var = case (lookupVarEnv env var) of
 570                       Nothing  -> var
 571                       Just var -> var
 572 \end{code}
 573
 574 Invent a fresh @Id@:
 575 \begin{code}
 576 newStgVar :: Type -> UniqSM Id
 577 newStgVar ty
 578  = getUniqueUs                  `thenUs` \ uniq ->
 579    returnUs (mkSysLocal SLIT("stg") uniq ty)
 580 \end{code}
 581
 582 \begin{code}
 583 newLocalId env id
 584   | externallyVisibleId id
 585   = returnUs (env, id)
 586
 587   | otherwise
 588   =     -- Local binder, give it a new unique Id.
 589     getUniqueUs                 `thenUs` \ uniq ->
 590     let
 591       id'     = setIdUnique id uniq
 592       new_env = extendVarEnv env id id'
 593     in
 594     returnUs (new_env, id')
 595
 596 -- we overload the demandInfo field of an Id to indicate whether the Id is definitely
 597 -- evaluated or not (i.e. whether it is a case binder).  This can be used to eliminate
 598 -- some redundant cases (c.f. dataToTag# above).
 599
 600 newEvaldLocalId env id
 601   = getUniqueUs                 `thenUs` \ uniq ->
 602     let
 603       id'     = setIdUnique id uniq `modifyIdInfo` setDemandInfo wwStrict
 604       new_env = extendVarEnv env id id'
 605     in
 606     returnUs (new_env, id')
 607
 608 newLocalIds :: StgEnv -> [Id] -> UniqSM (StgEnv, [Id])
 609 newLocalIds env []
 610   = returnUs (env, [])
 611 newLocalIds env (b:bs)
 612   = newLocalId env b    `thenUs` \ (env', b') ->
 613     newLocalIds env' bs `thenUs` \ (env'', bs') ->
 614     returnUs (env'', b':bs')
 615 \end{code}
 616
 617
 618 \begin{code}
 619 mkStgBinds :: [StgFloatBind] -> StgExpr -> StgExpr
 620 mkStgBinds binds body = foldr mkStgBind body binds
 621
 622 mkStgBind (StgFloatBind bndr rhs dem) body
 623   | isUnLiftedType bndr_ty
 624   = ASSERT( not ((isUnboxedTupleType bndr_ty) && (isStrictDem dem==False)) )
 625     mkStgCase rhs bndr (StgPrimAlts bndr_ty [] (StgBindDefault body))
 626
 627   | isStrictDem dem == True    -- case
 628   = mkStgCase rhs bndr (StgAlgAlts bndr_ty [] (StgBindDefault body))
 629
 630   | isStrictDem dem == False   -- let
 631   = StgLet (StgNonRec bndr (exprToRhs dem rhs)) body
 632   where
 633     bndr_ty = idType bndr
 634
 635 mkStgCase (StgLet bind expr) bndr alts
 636   = StgLet bind (mkStgCase expr bndr alts)
 637 mkStgCase scrut bndr alts
 638   = StgCase scrut bOGUS_LVs bOGUS_LVs bndr noSRT alts
 639 \end{code}