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, setIdType
  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 Convert 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 Mangle cases involving seq# in the discriminant.  Up to this
 586 point, seq# will appear like this:
 587
 588           case seq# e of
 589                 0# -> seqError#
 590                 _  -> ...
 591
 592 where the 0# branch is purely to bamboozle the strictness analyser
 593 This code comes from an unfolding for 'seq' in Prelude.hs.  We
 594 translate this into
 595
 596           case e of
 597                 _ -> ...
 598
 599 Now that the evaluation order is safe.
 600
 601 This used to be done in the post-simplification phase, but we need
 602 unfoldings involving seq# to appear unmangled in the interface file,
 603 hence we do this mangling here.
 604
 605 \begin{code}
 606 coreExprToStgFloat env
 607         (Case scrut@(Con (PrimOp SeqOp) [Type ty, e]) bndr alts) dem
 608   = coreExprToStgFloat env (Case e new_bndr [(DEFAULT,[],default_rhs)]) dem
 609   where new_bndr = setIdType bndr ty
 610         (other_alts, maybe_default)  = findDefault alts
 611         Just default_rhs             = maybe_default
 612 \end{code}
 613
 614 Now for normal case expressions...
 615
 616 \begin{code}
 617 coreExprToStgFloat env (Case scrut bndr alts) dem
 618   = coreExprToStgFloat env scrut (bdrDem bndr)  `thenUs` \ (binds, scrut') ->
 619     newEvaldLocalId env bndr                    `thenUs` \ (env', bndr') ->
 620     alts_to_stg env' (findDefault alts)         `thenUs` \ alts' ->
 621     returnUs (binds, mkStgCase scrut' bndr' alts')
 622   where
 623     scrut_ty  = idType bndr
 624     prim_case = isUnLiftedType scrut_ty && not (isUnboxedTupleType scrut_ty)
 625
 626     alts_to_stg env (alts, deflt)
 627       | prim_case
 628       = default_to_stg env deflt                `thenUs` \ deflt' ->
 629         mapUs (prim_alt_to_stg env) alts        `thenUs` \ alts' ->
 630         returnUs (StgPrimAlts scrut_ty alts' deflt')
 631
 632       | otherwise
 633       = default_to_stg env deflt                `thenUs` \ deflt' ->
 634         mapUs (alg_alt_to_stg env) alts         `thenUs` \ alts' ->
 635         returnUs (StgAlgAlts scrut_ty alts' deflt')
 636
 637     alg_alt_to_stg env (DataCon con, bs, rhs)
 638           = coreExprToStg env rhs dem   `thenUs` \ stg_rhs ->
 639             returnUs (con, filter isId bs, [ True | b <- bs ]{-bogus use mask-}, stg_rhs)
 640                 -- NB the filter isId.  Some of the binders may be
 641                 -- existential type variables, which STG doesn't care about
 642
 643     prim_alt_to_stg env (Literal lit, args, rhs)
 644           = ASSERT( null args )
 645             coreExprToStg env rhs dem   `thenUs` \ stg_rhs ->
 646             returnUs (lit, stg_rhs)
 647
 648     default_to_stg env Nothing
 649       = returnUs StgNoDefault
 650
 651     default_to_stg env (Just rhs)
 652       = coreExprToStg env rhs dem   `thenUs` \ stg_rhs ->
 653         returnUs (StgBindDefault stg_rhs)
 654                 -- The binder is used for prim cases and not otherwise
 655                 -- (hack for old code gen)
 656 \end{code}
 657
 658
 659 %************************************************************************
 660 %*                                                                      *
 661 \subsection[coreToStg-misc]{Miscellaneous helping functions}
 662 %*                                                                      *
 663 %************************************************************************
 664
 665 There's not anything interesting we can ASSERT about \tr{var} if it
 666 isn't in the StgEnv. (WDP 94/06)
 667
 668 \begin{code}
 669 stgLookup :: StgEnv -> Id -> Id
 670 stgLookup env var = case (lookupVarEnv env var) of
 671                       Nothing  -> var
 672                       Just var -> var
 673 \end{code}
 674
 675 Invent a fresh @Id@:
 676 \begin{code}
 677 newStgVar :: Type -> UniqSM Id
 678 newStgVar ty
 679  = getUniqueUs                  `thenUs` \ uniq ->
 680    returnUs (mkSysLocal SLIT("stg") uniq ty)
 681 \end{code}
 682
 683 \begin{code}
 684 -- we overload the demandInfo field of an Id to indicate whether the Id is definitely
 685 -- evaluated or not (i.e. whether it is a case binder).  This can be used to eliminate
 686 -- some redundant cases (c.f. dataToTag# above).
 687
 688 newEvaldLocalId env id
 689   = getUniqueUs                 `thenUs` \ uniq ->
 690     let
 691       id'     = modifyIdInfo (`setDemandInfo` wwStrict) (setIdUnique id uniq)
 692       new_env = extendVarEnv env id id'
 693     in
 694     returnUs (new_env, id')
 695
 696
 697 newLocalId TopLevel env id
 698   = returnUs (env, id)
 699   -- Don't clone top-level binders.  MkIface relies on their
 700   -- uniques staying the same, so it can snaffle IdInfo off the
 701   -- STG ids to put in interface files.
 702
 703 newLocalId NotTopLevel env id
 704   =     -- Local binder, give it a new unique Id.
 705     getUniqueUs                 `thenUs` \ uniq ->
 706     let
 707       id'     = setIdUnique id uniq
 708       new_env = extendVarEnv env id id'
 709     in
 710     returnUs (new_env, id')
 711
 712 newLocalIds :: TopLevelFlag -> StgEnv -> [Id] -> UniqSM (StgEnv, [Id])
 713 newLocalIds top_lev env []
 714   = returnUs (env, [])
 715 newLocalIds top_lev env (b:bs)
 716   = newLocalId top_lev env b    `thenUs` \ (env', b') ->
 717     newLocalIds top_lev env' bs `thenUs` \ (env'', bs') ->
 718     returnUs (env'', b':bs')
 719 \end{code}
 720
 721
 722 \begin{code}
 723 -- Stg doesn't have a lambda *expression*,
 724 deStgLam (StgLam ty bndrs body) = mkStgLamExpr ty bndrs body
 725 deStgLam expr                   = returnUs expr
 726
 727 mkStgLamExpr ty bndrs body
 728   = ASSERT( not (null bndrs) )
 729     newStgVar ty                `thenUs` \ fn ->
 730     returnUs (StgLet (StgNonRec fn lam_closure) (StgApp fn []))
 731   where
 732     lam_closure = StgRhsClosure noCCS
 733                                 stgArgOcc
 734                                 noSRT
 735                                 bOGUS_FVs
 736                                 ReEntrant       -- binders is non-empty
 737                                 bndrs
 738                                 body
 739
 740 mkStgBinds :: [StgFloatBind]
 741            -> StgExpr           -- *Can* be a StgLam
 742            -> UniqSM StgExpr    -- *Can* be a StgLam
 743
 744 mkStgBinds []     body = returnUs body
 745 mkStgBinds (b:bs) body
 746   = deStgLam body               `thenUs` \ body' ->
 747     go (b:bs) body'
 748   where
 749     go []     body = returnUs body
 750     go (b:bs) body = go bs body         `thenUs` \ body' ->
 751                      mkStgBind  b body'
 752
 753 -- The 'body' arg of mkStgBind can't be a StgLam
 754 mkStgBind NoBindF    body = returnUs body
 755 mkStgBind (RecF prs) body = returnUs (StgLet (StgRec prs) body)
 756
 757 mkStgBind (NonRecF bndr rhs dem floats) body
 758 #ifdef DEBUG
 759         -- We shouldn't get let or case of the form v=w
 760   = case rhs of
 761         StgApp v [] -> pprTrace "mkStgLet" (ppr bndr <+> ppr v)
 762                        (mk_stg_let bndr rhs dem floats body)
 763         other       ->  mk_stg_let bndr rhs dem floats body
 764
 765 mk_stg_let bndr rhs dem floats body
 766 #endif
 767   | isUnLiftedType bndr_ty                      -- Use a case/PrimAlts
 768   = ASSERT( not (isUnboxedTupleType bndr_ty) )
 769     mkStgBinds floats $
 770     mkStgCase rhs bndr (StgPrimAlts bndr_ty [] (StgBindDefault body))
 771
 772   | is_whnf
 773   = if is_strict then
 774         -- Strict let with WHNF rhs
 775         mkStgBinds floats $
 776         StgLet (StgNonRec bndr (exprToRhs dem rhs)) body
 777     else
 778         -- Lazy let with WHNF rhs; float until we find a strict binding
 779         let
 780             (floats_out, floats_in) = splitFloats floats
 781         in
 782         mkStgBinds floats_in rhs        `thenUs` \ new_rhs ->
 783         mkStgBinds floats_out $
 784         StgLet (StgNonRec bndr (exprToRhs dem new_rhs)) body
 785
 786   | otherwise   -- Not WHNF
 787   = if is_strict then
 788         -- Strict let with non-WHNF rhs
 789         mkStgBinds floats $
 790         mkStgCase rhs bndr (StgAlgAlts bndr_ty [] (StgBindDefault body))
 791     else
 792         -- Lazy let with non-WHNF rhs, so keep the floats in the RHS
 793         mkStgBinds floats rhs           `thenUs` \ new_rhs ->
 794         returnUs (StgLet (StgNonRec bndr (exprToRhs dem new_rhs)) body)
 795
 796   where
 797     bndr_ty   = idType bndr
 798     is_strict = isStrictDem dem
 799     is_whnf   = case rhs of
 800                   StgCon _ _ _ -> True
 801                   StgLam _ _ _ -> True
 802                   other        -> False
 803
 804 -- Split at the first strict binding
 805 splitFloats fs@(NonRecF _ _ dem _ : _)
 806   | isStrictDem dem = ([], fs)
 807
 808 splitFloats (f : fs) = case splitFloats fs of
 809                              (fs_out, fs_in) -> (f : fs_out, fs_in)
 810
 811 splitFloats [] = ([], [])
 812
 813
 814 mkStgCase scrut bndr alts
 815   = ASSERT( case scrut of { StgLam _ _ _ -> False; other -> True } )
 816         -- We should never find
 817         --      case (\x->e) of { ... }
 818         -- The simplifier eliminates such things
 819     StgCase scrut bOGUS_LVs bOGUS_LVs bndr noSRT alts
 820 \end{code}