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