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                   | RecF [(Id, StgRhs)]
 113                   | NonRecF
 114                         Id
 115                         StgExpr         -- *Can* be a StgLam
 116                         RhsDemand
 117                         [StgFloatBind]
 118
 119 -- The interesting one is the NonRecF
 120 --      NonRecF x rhs demand binds
 121 -- means
 122 --      x = let binds in rhs
 123 -- (or possibly case etc if x demand is strict)
 124 -- The binds are kept separate so they can be floated futher
 125 -- if appropriate
 126 \end{code}
 127
 128 A @RhsDemand@ gives the demand on an RHS: strict (@isStrictDem@) and
 129 thus case-bound, or if let-bound, at most once (@isOnceDem@) or
 130 otherwise.
 131
 132 \begin{code}
 133 data RhsDemand  = RhsDemand { isStrictDem :: Bool,  -- True => used at least once
 134                               isOnceDem   :: Bool   -- True => used at most once
 135                             }
 136
 137 mkDem :: Demand -> Bool -> RhsDemand
 138 mkDem strict once = RhsDemand (isStrict strict) once
 139
 140 mkDemTy :: Demand -> Type -> RhsDemand
 141 mkDemTy strict ty = RhsDemand (isStrict strict) (isOnceTy ty)
 142
 143 isOnceTy :: Type -> Bool
 144 isOnceTy ty = case tyUsg ty of
 145                      UsOnce -> True
 146                      UsMany -> False
 147
 148 bdrDem :: Id -> RhsDemand
 149 bdrDem id = mkDem (getIdDemandInfo id) (isOnceTy (idType id))
 150
 151 safeDem, onceDem :: RhsDemand
 152 safeDem = RhsDemand False False  -- always safe to use this
 153 onceDem = RhsDemand False True   -- used at most once
 154 \end{code}
 155
 156 No free/live variable information is pinned on in this pass; it's added
 157 later.  For this pass
 158 we use @bOGUS_LVs@ and @bOGUS_FVs@ as placeholders.
 159
 160 \begin{code}
 161 bOGUS_LVs :: StgLiveVars
 162 bOGUS_LVs = panic "bOGUS_LVs" -- emptyUniqSet (used when pprTracing)
 163
 164 bOGUS_FVs :: [Id]
 165 bOGUS_FVs = panic "bOGUS_FVs" -- [] (ditto)
 166 \end{code}
 167
 168 \begin{code}
 169 topCoreBindsToStg :: UniqSupply -- name supply
 170                   -> [CoreBind] -- input
 171                   -> [StgBinding]       -- output
 172
 173 topCoreBindsToStg us core_binds
 174   = initUs_ us (coreBindsToStg emptyVarEnv core_binds)
 175   where
 176     coreBindsToStg :: StgEnv -> [CoreBind] -> UniqSM [StgBinding]
 177
 178     coreBindsToStg env [] = returnUs []
 179     coreBindsToStg env (b:bs)
 180       = coreBindToStg  TopLevel env b   `thenUs` \ (bind_spec, new_env) ->
 181         coreBindsToStg new_env bs       `thenUs` \ new_bs ->
 182         case bind_spec of
 183           NonRecF bndr rhs dem floats
 184                 -> ASSERT2( not (isStrictDem dem) &&
 185                             not (isUnLiftedType (idType bndr)),
 186                             ppr b )             -- No top-level cases!
 187
 188                    mkStgBinds floats rhs        `thenUs` \ new_rhs ->
 189                    returnUs (StgNonRec bndr (exprToRhs dem new_rhs) : new_bs)
 190                                         -- Keep all the floats inside...
 191                                         -- Some might be cases etc
 192                                         -- We might want to revisit this decision
 193
 194           RecF prs -> returnUs (StgRec prs : new_bs)
 195           NoBindF  -> pprTrace "topCoreBindsToStg" (ppr b) $
 196                       returnUs new_bs
 197 \end{code}
 198
 199
 200 %************************************************************************
 201 %*                                                                      *
 202 \subsection[coreToStg-binds]{Converting bindings}
 203 %*                                                                      *
 204 %************************************************************************
 205
 206 \begin{code}
 207 coreBindToStg :: TopLevelFlag -> StgEnv -> CoreBind -> UniqSM (StgFloatBind, StgEnv)
 208
 209 coreBindToStg top_lev env (NonRec binder rhs)
 210   = coreExprToStgFloat env rhs dem                      `thenUs` \ (floats, stg_rhs) ->
 211     case (floats, stg_rhs) of
 212         ([], StgApp var []) | not (isExportedId binder)
 213                      -> returnUs (NoBindF, extendVarEnv env binder var)
 214                 -- A trivial binding let x = y in ...
 215                 -- can arise if postSimplExpr floats a NoRep literal out
 216                 -- so it seems sensible to deal with it well.
 217                 -- But we don't want to discard exported things.  They can
 218                 -- occur; e.g. an exported user binding f = g
 219
 220         other -> newLocalId top_lev env binder          `thenUs` \ (new_env, new_binder) ->
 221                  returnUs (NonRecF new_binder stg_rhs dem floats, new_env)
 222   where
 223     dem = bdrDem binder
 224
 225 coreBindToStg top_lev env (Rec pairs)
 226   = newLocalIds top_lev env binders     `thenUs` \ (env', binders') ->
 227     mapUs (do_rhs env') pairs           `thenUs` \ stg_rhss ->
 228     returnUs (RecF (binders' `zip` stg_rhss), env')
 229   where
 230     binders = map fst pairs
 231     do_rhs env (bndr,rhs) = coreExprToStgFloat env rhs dem      `thenUs` \ (floats, stg_expr) ->
 232                             mkStgBinds floats stg_expr          `thenUs` \ stg_expr' ->
 233                                 -- NB: stg_expr' might still be a StgLam (and we want that)
 234                             returnUs (exprToRhs dem stg_expr')
 235                           where
 236                             dem = bdrDem bndr
 237 \end{code}
 238
 239
 240 %************************************************************************
 241 %*                                                                      *
 242 \subsection[coreToStg-rhss]{Converting right hand sides}
 243 %*                                                                      *
 244 %************************************************************************
 245
 246 \begin{code}
 247 exprToRhs :: RhsDemand -> StgExpr -> StgRhs
 248 exprToRhs dem (StgLam _ bndrs body)
 249   = ASSERT( not (null bndrs) )
 250     StgRhsClosure noCCS
 251                   stgArgOcc
 252                   noSRT
 253                   bOGUS_FVs
 254                   ReEntrant     -- binders is non-empty
 255                   bndrs
 256                   body
 257
 258 {-
 259   We reject the following candidates for 'static constructor'dom:
 260
 261     - any dcon that takes a lit-lit as an arg.
 262     - [Win32 DLLs only]: any dcon that is (or takes as arg)
 263       that's living in a DLL.
 264
 265   These constraints are necessary to ensure that the code
 266   generated in the end for the static constructors, which
 267   live in the data segment, remain valid - i.e., it has to
 268   be constant. For obvious reasons, that's hard to guarantee
 269   with lit-lits. The second case of a constructor referring
 270   to static closures hiding out in some DLL is an artifact
 271   of the way Win32 DLLs handle global DLL variables. A (data)
 272   symbol exported from a DLL  has to be accessed through a
 273   level of indirection at the site of use, so whereas
 274
 275      extern StgClosure y_closure;
 276      extern StgClosure z_closure;
 277      x = { ..., &y_closure, &z_closure };
 278
 279   is legal when the symbols are in scope at link-time, it is
 280   not when y_closure is in a DLL. So, any potential static
 281   closures that refers to stuff that's residing in a DLL
 282   will be put in an (updateable) thunk instead.
 283
 284   An alternative strategy is to support the generation of
 285   constructors (ala C++ static class constructors) which will
 286   then be run at load time to fix up static closures.
 287 -}
 288 exprToRhs dem (StgCon (DataCon con) args _)
 289   | not is_dynamic  &&
 290     all  (not.is_lit_lit) args  = StgRhsCon noCCS con args
 291  where
 292   is_dynamic = isDynCon con || any (isDynArg) args
 293
 294   is_lit_lit (StgVarArg _) = False
 295   is_lit_lit (StgConArg x) =
 296      case x of
 297        Literal l -> isLitLitLit l
 298        _         -> False
 299
 300 exprToRhs dem expr
 301         = StgRhsClosure noCCS           -- No cost centre (ToDo?)
 302                         stgArgOcc       -- safe
 303                         noSRT           -- figure out later
 304                         bOGUS_FVs
 305                         (if isOnceDem dem then SingleEntry else Updatable)
 306                                 -- HA!  Paydirt for "dem"
 307                         []
 308                         expr
 309
 310 isDynCon :: DataCon -> Bool
 311 isDynCon con = isDynName (dataConName con)
 312
 313 isDynArg :: StgArg -> Bool
 314 isDynArg (StgVarArg v)   = isDynName (idName v)
 315 isDynArg (StgConArg con) =
 316   case con of
 317     DataCon dc -> isDynCon dc
 318     Literal l  -> isLitLitLit l
 319     _          -> False
 320
 321 isDynName :: Name -> Bool
 322 isDynName nm =
 323       not (isLocallyDefinedName nm) &&
 324       isDynamicModule (nameModule nm)
 325 \end{code}
 326
 327
 328 %************************************************************************
 329 %*                                                                      *
 330 \subsection[coreToStg-atoms{Converting atoms}
 331 %*                                                                      *
 332 %************************************************************************
 333
 334 \begin{code}
 335 coreArgsToStg :: StgEnv -> [(CoreArg,RhsDemand)] -> UniqSM ([StgFloatBind], [StgArg])
 336 -- Arguments are all value arguments (tyargs already removed), paired with their demand
 337
 338 coreArgsToStg env []
 339   = returnUs ([], [])
 340
 341 coreArgsToStg env (ad:ads)
 342   = coreArgToStg env ad         `thenUs` \ (bs1, a') ->
 343     coreArgsToStg env ads       `thenUs` \ (bs2, as') ->
 344     returnUs (bs1 ++ bs2, a' : as')
 345
 346
 347 coreArgToStg :: StgEnv -> (CoreArg,RhsDemand) -> UniqSM ([StgFloatBind], StgArg)
 348 -- This is where we arrange that a non-trivial argument is let-bound
 349
 350 coreArgToStg env (arg,dem)
 351   = coreExprToStgFloat env arg dem              `thenUs` \ (floats, arg') ->
 352     case arg' of
 353         StgCon con [] _ -> returnUs (floats, StgConArg con)
 354         StgApp v []     -> returnUs (floats, StgVarArg v)
 355         other           -> newStgVar arg_ty     `thenUs` \ v ->
 356                            returnUs ([NonRecF v arg' dem floats], StgVarArg v)
 357   where
 358     arg_ty = coreExprType arg
 359 \end{code}
 360
 361
 362 %************************************************************************
 363 %*                                                                      *
 364 \subsection[coreToStg-exprs]{Converting core expressions}
 365 %*                                                                      *
 366 %************************************************************************
 367
 368 \begin{code}
 369 coreExprToStg :: StgEnv -> CoreExpr -> RhsDemand -> UniqSM StgExpr
 370 coreExprToStg env expr dem
 371   = coreExprToStgFloat env expr dem     `thenUs` \ (binds,stg_expr) ->
 372     mkStgBinds binds stg_expr           `thenUs` \ stg_expr' ->
 373     deStgLam stg_expr'
 374 \end{code}
 375
 376 %************************************************************************
 377 %*                                                                      *
 378 \subsubsection[coreToStg-let(rec)]{Let and letrec expressions}
 379 %*                                                                      *
 380 %************************************************************************
 381
 382 \begin{code}
 383 coreExprToStgFloat :: StgEnv -> CoreExpr
 384                    -> RhsDemand
 385                    -> UniqSM ([StgFloatBind], StgExpr)
 386 -- Transform an expression to STG. The demand on the expression is
 387 -- given by RhsDemand, and is solely used ot figure out the usage
 388 -- of constructor args: if the constructor is used once, then so are
 389 -- its arguments.  The strictness info in RhsDemand isn't used.
 390
 391 -- The StgExpr returned *can* be an StgLam
 392 \end{code}
 393
 394 Simple cases first
 395
 396 \begin{code}
 397 coreExprToStgFloat env (Var var) dem
 398   = returnUs ([], StgApp (stgLookup env var) [])
 399
 400 coreExprToStgFloat env (Let bind body) dem
 401   = coreBindToStg NotTopLevel env bind  `thenUs` \ (new_bind, new_env) ->
 402     coreExprToStgFloat new_env body dem `thenUs` \ (floats, stg_body) ->
 403     returnUs (new_bind:floats, stg_body)
 404 \end{code}
 405
 406 Covert core @scc@ expression directly to STG @scc@ expression.
 407
 408 \begin{code}
 409 coreExprToStgFloat env (Note (SCC cc) expr) dem
 410   = coreExprToStg env expr dem  `thenUs` \ stg_expr ->
 411     returnUs ([], StgSCC cc stg_expr)
 412
 413 coreExprToStgFloat env (Note other_note expr) dem
 414   = coreExprToStgFloat env expr dem
 415 \end{code}
 416
 417 \begin{code}
 418 coreExprToStgFloat env expr@(Type _) dem
 419   = pprPanic "coreExprToStgFloat: tyarg unexpected:" $ ppr expr
 420 \end{code}
 421
 422
 423 %************************************************************************
 424 %*                                                                      *
 425 \subsubsection[coreToStg-lambdas]{Lambda abstractions}
 426 %*                                                                      *
 427 %************************************************************************
 428
 429 \begin{code}
 430 coreExprToStgFloat env expr@(Lam _ _) dem
 431   = let
 432         expr_ty         = coreExprType expr
 433         (binders, body) = collectBinders expr
 434         id_binders      = filter isId binders
 435         body_dem        = trace "coreExprToStg: approximating body_dem in Lam"
 436                           safeDem
 437     in
 438     if null id_binders then     -- It was all type/usage binders; tossed
 439         coreExprToStgFloat env body dem
 440     else
 441         -- At least some value binders
 442     newLocalIds NotTopLevel env id_binders      `thenUs` \ (env', binders') ->
 443     coreExprToStgFloat env' body body_dem       `thenUs` \ (floats, stg_body) ->
 444     mkStgBinds floats stg_body                  `thenUs` \ stg_body' ->
 445
 446     case stg_body' of
 447       StgLam ty lam_bndrs lam_body ->
 448                 -- If the body reduced to a lambda too, join them up
 449           returnUs ([], StgLam expr_ty (binders' ++ lam_bndrs) lam_body)
 450
 451       other ->
 452                 -- Body didn't reduce to a lambda, so return one
 453           returnUs ([], StgLam expr_ty binders' stg_body')
 454 \end{code}
 455
 456
 457 %************************************************************************
 458 %*                                                                      *
 459 \subsubsection[coreToStg-applications]{Applications}
 460 %*                                                                      *
 461 %************************************************************************
 462
 463 \begin{code}
 464 coreExprToStgFloat env expr@(App _ _) dem
 465   = let
 466         (fun,rads,_,_) = collect_args expr
 467         ads            = reverse rads
 468     in
 469     coreArgsToStg env ads               `thenUs` \ (arg_floats, stg_args) ->
 470
 471         -- Now deal with the function
 472     case (fun, stg_args) of
 473       (Var fun_id, _) ->        -- A function Id, so do an StgApp; it's ok if
 474                                 -- there are no arguments.
 475                             returnUs (arg_floats,
 476                                       StgApp (stgLookup env fun_id) stg_args)
 477
 478       (non_var_fun, []) ->      -- No value args, so recurse into the function
 479                             ASSERT( null arg_floats )
 480                             coreExprToStgFloat env non_var_fun dem
 481
 482       other ->  -- A non-variable applied to things; better let-bind it.
 483                 newStgVar (coreExprType fun)            `thenUs` \ fun_id ->
 484                 coreExprToStgFloat env fun onceDem      `thenUs` \ (fun_floats, stg_fun) ->
 485                 returnUs (NonRecF fun_id stg_fun onceDem fun_floats : arg_floats,
 486                           StgApp fun_id stg_args)
 487
 488   where
 489         -- Collect arguments and demands (*in reverse order*)
 490         -- collect_args e = (f, args_w_demands, ty, stricts)
 491         --  => e = f tys args,  (i.e. args are just the value args)
 492         --     e :: ty
 493         --     stricts is the leftover demands of e on its further args
 494         -- If stricts runs out, we zap all the demands in args_w_demands
 495         -- because partial applications are lazy
 496
 497     collect_args :: CoreExpr -> (CoreExpr, [(CoreExpr,RhsDemand)], Type, [Demand])
 498
 499     collect_args (Note (Coerce ty _) e) = let (the_fun,ads,_,ss) = collect_args e
 500                                           in  (the_fun,ads,ty,ss)
 501     collect_args (Note InlineCall    e) = collect_args e
 502     collect_args (Note (TermUsg _)   e) = collect_args e
 503
 504     collect_args (App fun (Type tyarg)) = let (the_fun,ads,fun_ty,ss) = collect_args fun
 505                                           in  (the_fun,ads,applyTy fun_ty tyarg,ss)
 506     collect_args (App fun arg)
 507         = case ss of
 508             []            ->    -- Strictness info has run out
 509                              (the_fun, (arg, mkDemTy wwLazy arg_ty) : zap ads, res_ty, repeat wwLazy)
 510             (ss1:ss_rest) ->    -- Enough strictness info
 511                              (the_fun, (arg, mkDemTy ss1 arg_ty)    : ads,     res_ty, ss_rest)
 512         where
 513           (the_fun, ads, fun_ty, ss) = collect_args fun
 514           (arg_ty, res_ty)           = expectJust "coreExprToStgFloat:collect_args" $
 515                                        splitFunTy_maybe fun_ty
 516
 517     collect_args (Var v)
 518         = (Var v, [], idType v, stricts)
 519         where
 520           stricts = case getIdStrictness v of
 521                         StrictnessInfo demands _ -> demands
 522                         other                    -> repeat wwLazy
 523
 524     collect_args fun = (fun, [], coreExprType fun, repeat wwLazy)
 525
 526     -- "zap" nukes the strictness info for a partial application
 527     zap ads = [(arg, RhsDemand False once) | (arg, RhsDemand _ once) <- ads]
 528 \end{code}
 529
 530 %************************************************************************
 531 %*                                                                      *
 532 \subsubsection[coreToStg-con]{Constructors and primops}
 533 %*                                                                      *
 534 %************************************************************************
 535
 536 For data constructors, the demand on an argument is the demand on the
 537 constructor as a whole (see module UsageSPInf).  For primops, the
 538 demand is derived from the type of the primop.
 539
 540 If usage inference is off, we simply make all bindings updatable for
 541 speed.
 542
 543 \begin{code}
 544 coreExprToStgFloat env expr@(Con con args) dem
 545   = let
 546         (stricts,_) = conStrictness con
 547         onces = case con of
 548                     DEFAULT   -> panic "coreExprToStgFloat: DEFAULT"
 549
 550                     Literal _ -> ASSERT( null args' {-'cpp-} ) []
 551
 552                     DataCon c -> repeat (isOnceDem dem)
 553                                         -- HA!  This is the sole reason we propagate
 554                                         -- dem all the way down
 555
 556                     PrimOp  p -> let tyargs      = map (\ (Type ty) -> ty) $
 557                                                        takeWhile isTypeArg args
 558                                      (arg_tys,_) = primOpUsgTys p tyargs
 559                                  in  ASSERT( length arg_tys == length args' {-'cpp-} )
 560                                      -- primops always fully applied, so == not >=
 561                                      map isOnceTy arg_tys
 562
 563         dems' = zipWith mkDem stricts onces
 564         args' = filter isValArg args
 565     in
 566     coreArgsToStg env (zip args' dems')                  `thenUs` \ (arg_floats, stg_atoms) ->
 567
 568         -- YUK YUK: must unique if present
 569     (case con of
 570        PrimOp (CCallOp (Right _) a b c) -> getUniqueUs   `thenUs` \ u ->
 571                                            returnUs (PrimOp (CCallOp (Right u) a b c))
 572        _                                -> returnUs con
 573     )                                                     `thenUs` \ con' ->
 574
 575     returnUs (arg_floats, StgCon con' stg_atoms (coreExprType expr))
 576 \end{code}
 577
 578
 579 %************************************************************************
 580 %*                                                                      *
 581 \subsubsection[coreToStg-cases]{Case expressions}
 582 %*                                                                      *
 583 %************************************************************************
 584
 585 \begin{code}
 586 coreExprToStgFloat env (Case scrut bndr alts) dem
 587   = coreExprToStgFloat env scrut (bdrDem bndr)  `thenUs` \ (binds, scrut') ->
 588     newEvaldLocalId env bndr                    `thenUs` \ (env', bndr') ->
 589     alts_to_stg env' (findDefault alts)         `thenUs` \ alts' ->
 590     returnUs (binds, mkStgCase scrut' bndr' alts')
 591   where
 592     scrut_ty  = idType bndr
 593     prim_case = isUnLiftedType scrut_ty && not (isUnboxedTupleType scrut_ty)
 594
 595     alts_to_stg env (alts, deflt)
 596       | prim_case
 597       = default_to_stg env deflt                `thenUs` \ deflt' ->
 598         mapUs (prim_alt_to_stg env) alts        `thenUs` \ alts' ->
 599         returnUs (StgPrimAlts scrut_ty alts' deflt')
 600
 601       | otherwise
 602       = default_to_stg env deflt                `thenUs` \ deflt' ->
 603         mapUs (alg_alt_to_stg env) alts         `thenUs` \ alts' ->
 604         returnUs (StgAlgAlts scrut_ty alts' deflt')
 605
 606     alg_alt_to_stg env (DataCon con, bs, rhs)
 607           = coreExprToStg env rhs dem   `thenUs` \ stg_rhs ->
 608             returnUs (con, filter isId bs, [ True | b <- bs ]{-bogus use mask-}, stg_rhs)
 609                 -- NB the filter isId.  Some of the binders may be
 610                 -- existential type variables, which STG doesn't care about
 611
 612     prim_alt_to_stg env (Literal lit, args, rhs)
 613           = ASSERT( null args )
 614             coreExprToStg env rhs dem   `thenUs` \ stg_rhs ->
 615             returnUs (lit, stg_rhs)
 616
 617     default_to_stg env Nothing
 618       = returnUs StgNoDefault
 619
 620     default_to_stg env (Just rhs)
 621       = coreExprToStg env rhs dem   `thenUs` \ stg_rhs ->
 622         returnUs (StgBindDefault stg_rhs)
 623                 -- The binder is used for prim cases and not otherwise
 624                 -- (hack for old code gen)
 625 \end{code}
 626
 627
 628 %************************************************************************
 629 %*                                                                      *
 630 \subsection[coreToStg-misc]{Miscellaneous helping functions}
 631 %*                                                                      *
 632 %************************************************************************
 633
 634 There's not anything interesting we can ASSERT about \tr{var} if it
 635 isn't in the StgEnv. (WDP 94/06)
 636
 637 \begin{code}
 638 stgLookup :: StgEnv -> Id -> Id
 639 stgLookup env var = case (lookupVarEnv env var) of
 640                       Nothing  -> var
 641                       Just var -> var
 642 \end{code}
 643
 644 Invent a fresh @Id@:
 645 \begin{code}
 646 newStgVar :: Type -> UniqSM Id
 647 newStgVar ty
 648  = getUniqueUs                  `thenUs` \ uniq ->
 649    returnUs (mkSysLocal SLIT("stg") uniq ty)
 650 \end{code}
 651
 652 \begin{code}
 653 -- we overload the demandInfo field of an Id to indicate whether the Id is definitely
 654 -- evaluated or not (i.e. whether it is a case binder).  This can be used to eliminate
 655 -- some redundant cases (c.f. dataToTag# above).
 656
 657 newEvaldLocalId env id
 658   = getUniqueUs                 `thenUs` \ uniq ->
 659     let
 660       id'     = modifyIdInfo (`setDemandInfo` wwStrict) (setIdUnique id uniq)
 661       new_env = extendVarEnv env id id'
 662     in
 663     returnUs (new_env, id')
 664
 665
 666 newLocalId TopLevel env id
 667   = returnUs (env, id)
 668   -- Don't clone top-level binders.  MkIface relies on their
 669   -- uniques staying the same, so it can snaffle IdInfo off the
 670   -- STG ids to put in interface files.
 671
 672 newLocalId NotTopLevel env id
 673   =     -- Local binder, give it a new unique Id.
 674     getUniqueUs                 `thenUs` \ uniq ->
 675     let
 676       id'     = setIdUnique id uniq
 677       new_env = extendVarEnv env id id'
 678     in
 679     returnUs (new_env, id')
 680
 681 newLocalIds :: TopLevelFlag -> StgEnv -> [Id] -> UniqSM (StgEnv, [Id])
 682 newLocalIds top_lev env []
 683   = returnUs (env, [])
 684 newLocalIds top_lev env (b:bs)
 685   = newLocalId top_lev env b    `thenUs` \ (env', b') ->
 686     newLocalIds top_lev env' bs `thenUs` \ (env'', bs') ->
 687     returnUs (env'', b':bs')
 688 \end{code}
 689
 690
 691 \begin{code}
 692 -- Stg doesn't have a lambda *expression*,
 693 deStgLam (StgLam ty bndrs body) = mkStgLamExpr ty bndrs body
 694 deStgLam expr                   = returnUs expr
 695
 696 mkStgLamExpr ty bndrs body
 697   = ASSERT( not (null bndrs) )
 698     newStgVar ty                `thenUs` \ fn ->
 699     returnUs (StgLet (StgNonRec fn lam_closure) (StgApp fn []))
 700   where
 701     lam_closure = StgRhsClosure noCCS
 702                                 stgArgOcc
 703                                 noSRT
 704                                 bOGUS_FVs
 705                                 ReEntrant       -- binders is non-empty
 706                                 bndrs
 707                                 body
 708
 709 mkStgBinds :: [StgFloatBind]
 710            -> StgExpr           -- *Can* be a StgLam
 711            -> UniqSM StgExpr    -- *Can* be a StgLam
 712
 713 mkStgBinds []     body = returnUs body
 714 mkStgBinds (b:bs) body
 715   = deStgLam body               `thenUs` \ body' ->
 716     go (b:bs) body'
 717   where
 718     go []     body = returnUs body
 719     go (b:bs) body = go bs body         `thenUs` \ body' ->
 720                      mkStgBind  b body'
 721
 722 -- The 'body' arg of mkStgBind can't be a StgLam
 723 mkStgBind NoBindF    body = returnUs body
 724 mkStgBind (RecF prs) body = returnUs (StgLet (StgRec prs) body)
 725
 726 mkStgBind (NonRecF bndr rhs dem floats) body
 727 #ifdef DEBUG
 728         -- We shouldn't get let or case of the form v=w
 729   = case rhs of
 730         StgApp v [] -> pprTrace "mkStgLet" (ppr bndr <+> ppr v)
 731                        (mk_stg_let bndr rhs dem floats body)
 732         other       ->  mk_stg_let bndr rhs dem floats body
 733
 734 mk_stg_let bndr rhs dem floats body
 735 #endif
 736   | isUnLiftedType bndr_ty                      -- Use a case/PrimAlts
 737   = ASSERT( not (isUnboxedTupleType bndr_ty) )
 738     mkStgBinds floats $
 739     mkStgCase rhs bndr (StgPrimAlts bndr_ty [] (StgBindDefault body))
 740
 741   | is_whnf
 742   = if is_strict then
 743         -- Strict let with WHNF rhs
 744         mkStgBinds floats $
 745         StgLet (StgNonRec bndr (exprToRhs dem rhs)) body
 746     else
 747         -- Lazy let with WHNF rhs; float until we find a strict binding
 748         let
 749             (floats_out, floats_in) = splitFloats floats
 750         in
 751         mkStgBinds floats_in rhs        `thenUs` \ new_rhs ->
 752         mkStgBinds floats_out $
 753         StgLet (StgNonRec bndr (exprToRhs dem new_rhs)) body
 754
 755   | otherwise   -- Not WHNF
 756   = if is_strict then
 757         -- Strict let with non-WHNF rhs
 758         mkStgBinds floats $
 759         mkStgCase rhs bndr (StgAlgAlts bndr_ty [] (StgBindDefault body))
 760     else
 761         -- Lazy let with non-WHNF rhs, so keep the floats in the RHS
 762         mkStgBinds floats rhs           `thenUs` \ new_rhs ->
 763         returnUs (StgLet (StgNonRec bndr (exprToRhs dem new_rhs)) body)
 764
 765   where
 766     bndr_ty   = idType bndr
 767     is_strict = isStrictDem dem
 768     is_whnf   = case rhs of
 769                   StgCon _ _ _ -> True
 770                   StgLam _ _ _ -> True
 771                   other        -> False
 772
 773 -- Split at the first strict binding
 774 splitFloats fs@(NonRecF _ _ dem _ : _)
 775   | isStrictDem dem = ([], fs)
 776
 777 splitFloats (f : fs) = case splitFloats fs of
 778                              (fs_out, fs_in) -> (f : fs_out, fs_in)
 779
 780 splitFloats [] = ([], [])
 781
 782
 783 mkStgCase scrut bndr alts
 784   = ASSERT( case scrut of { StgLam _ _ _ -> False; other -> True } )
 785         -- We should never find
 786         --      case (\x->e) of { ... }
 787         -- The simplifier eliminates such things
 788     StgCase scrut bOGUS_LVs bOGUS_LVs bndr noSRT alts
 789 \end{code}