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,_,ss)       = collect_args expr
 467         ads                   = reverse rads
 468         final_ads | null ss   = ads
 469                   | otherwise = zap ads -- Too few args to satisfy strictness info
 470                                         -- so we have to ignore all the strictness info
 471                                         -- e.g. + (error "urk")
 472                                         -- Here, we can't evaluate the arg strictly,
 473                                         -- because this partial application might be seq'd
 474     in
 475     coreArgsToStg env final_ads         `thenUs` \ (arg_floats, stg_args) ->
 476
 477         -- Now deal with the function
 478     case (fun, stg_args) of
 479       (Var fun_id, _) ->        -- A function Id, so do an StgApp; it's ok if
 480                                 -- there are no arguments.
 481                             returnUs (arg_floats,
 482                                       StgApp (stgLookup env fun_id) stg_args)
 483
 484       (non_var_fun, []) ->      -- No value args, so recurse into the function
 485                             ASSERT( null arg_floats )
 486                             coreExprToStgFloat env non_var_fun dem
 487
 488       other ->  -- A non-variable applied to things; better let-bind it.
 489                 newStgVar (coreExprType fun)            `thenUs` \ fun_id ->
 490                 coreExprToStgFloat env fun onceDem      `thenUs` \ (fun_floats, stg_fun) ->
 491                 returnUs (NonRecF fun_id stg_fun onceDem fun_floats : arg_floats,
 492                           StgApp fun_id stg_args)
 493
 494   where
 495         -- Collect arguments and demands (*in reverse order*)
 496         -- collect_args e = (f, args_w_demands, ty, stricts)
 497         --  => e = f tys args,  (i.e. args are just the value args)
 498         --     e :: ty
 499         --     stricts is the leftover demands of e on its further args
 500         -- If stricts runs out, we zap all the demands in args_w_demands
 501         -- because partial applications are lazy
 502
 503     collect_args :: CoreExpr -> (CoreExpr, [(CoreExpr,RhsDemand)], Type, [Demand])
 504
 505     collect_args (Note (Coerce ty _) e) = let (the_fun,ads,_,ss) = collect_args e
 506                                           in  (the_fun,ads,ty,ss)
 507     collect_args (Note InlineCall    e) = collect_args e
 508     collect_args (Note (TermUsg _)   e) = collect_args e
 509
 510     collect_args (App fun (Type tyarg)) = let (the_fun,ads,fun_ty,ss) = collect_args fun
 511                                           in  (the_fun,ads,applyTy fun_ty tyarg,ss)
 512     collect_args (App fun arg)
 513         = (the_fun, (arg, mkDemTy ss1 arg_ty) : ads, res_ty, ss_rest)
 514         where
 515           (ss1, ss_rest)             = case ss of
 516                                          (ss1:ss_rest) -> (ss1, ss_rest)
 517                                          []            -> (wwLazy, [])
 518           (the_fun, ads, fun_ty, ss) = collect_args fun
 519           (arg_ty, res_ty)           = expectJust "coreExprToStgFloat:collect_args" $
 520                                        splitFunTy_maybe fun_ty
 521
 522     collect_args (Var v)
 523         = (Var v, [], idType v, stricts)
 524         where
 525           stricts = case getIdStrictness v of
 526                         StrictnessInfo demands _ -> demands
 527                         other                    -> repeat wwLazy
 528
 529     collect_args fun = (fun, [], coreExprType fun, repeat wwLazy)
 530
 531     -- "zap" nukes the strictness info for a partial application
 532     zap ads = [(arg, RhsDemand False once) | (arg, RhsDemand _ once) <- ads]
 533 \end{code}
 534
 535 %************************************************************************
 536 %*                                                                      *
 537 \subsubsection[coreToStg-con]{Constructors and primops}
 538 %*                                                                      *
 539 %************************************************************************
 540
 541 For data constructors, the demand on an argument is the demand on the
 542 constructor as a whole (see module UsageSPInf).  For primops, the
 543 demand is derived from the type of the primop.
 544
 545 If usage inference is off, we simply make all bindings updatable for
 546 speed.
 547
 548 \begin{code}
 549 coreExprToStgFloat env expr@(Con con args) dem
 550   = let
 551         (stricts,_) = conStrictness con
 552         onces = case con of
 553                     DEFAULT   -> panic "coreExprToStgFloat: DEFAULT"
 554
 555                     Literal _ -> ASSERT( null args' {-'cpp-} ) []
 556
 557                     DataCon c -> repeat (isOnceDem dem)
 558                                         -- HA!  This is the sole reason we propagate
 559                                         -- dem all the way down
 560
 561                     PrimOp  p -> let tyargs      = map (\ (Type ty) -> ty) $
 562                                                        takeWhile isTypeArg args
 563                                      (arg_tys,_) = primOpUsgTys p tyargs
 564                                  in  ASSERT( length arg_tys == length args' {-'cpp-} )
 565                                      -- primops always fully applied, so == not >=
 566                                      map isOnceTy arg_tys
 567
 568         dems' = zipWith mkDem stricts onces
 569         args' = filter isValArg args
 570     in
 571     coreArgsToStg env (zip args' dems')                  `thenUs` \ (arg_floats, stg_atoms) ->
 572
 573         -- YUK YUK: must unique if present
 574     (case con of
 575        PrimOp (CCallOp (Right _) a b c) -> getUniqueUs   `thenUs` \ u ->
 576                                            returnUs (PrimOp (CCallOp (Right u) a b c))
 577        _                                -> returnUs con
 578     )                                                     `thenUs` \ con' ->
 579
 580     returnUs (arg_floats, StgCon con' stg_atoms (coreExprType expr))
 581 \end{code}
 582
 583
 584 %************************************************************************
 585 %*                                                                      *
 586 \subsubsection[coreToStg-cases]{Case expressions}
 587 %*                                                                      *
 588 %************************************************************************
 589
 590 First, two special cases.  We mangle cases involving
 591                 par# and seq#
 592 inthe scrutinee.
 593
 594 Up to this point, seq# will appear like this:
 595
 596           case seq# e of
 597                 0# -> seqError#
 598                 _  -> <stuff>
 599
 600 This code comes from an unfolding for 'seq' in Prelude.hs.
 601 The 0# branch is purely to bamboozle the strictness analyser.
 602 For example, if <stuff> is strict in x, and there was no seqError#
 603 branch, the strictness analyser would conclude that the whole expression
 604 was strict in x, and perhaps evaluate x first -- but that would be a DISASTER.
 605
 606 Now that the evaluation order is safe, we translate this into
 607
 608           case e of
 609                 _ -> ...
 610
 611 This used to be done in the post-simplification phase, but we need
 612 unfoldings involving seq# to appear unmangled in the interface file,
 613 hence we do this mangling here.
 614
 615 Similarly, par# has an unfolding in PrelConc.lhs that makes it show
 616 up like this:
 617
 618         case par# e of
 619           0# -> rhs
 620           _  -> parError#
 621
 622
 623     ==>
 624         case par# e of
 625           _ -> rhs
 626
 627 fork# isn't handled like this - it's an explicit IO operation now.
 628 The reason is that fork# returns a ThreadId#, which gets in the
 629 way of the above scheme.  And anyway, IO is the only guaranteed
 630 way to enforce ordering  --SDM.
 631
 632
 633 \begin{code}
 634 coreExprToStgFloat env
 635         (Case scrut@(Con (PrimOp SeqOp) [Type ty, e]) bndr alts) dem
 636   = coreExprToStgFloat env (Case e new_bndr [(DEFAULT,[],default_rhs)]) dem
 637   where
 638     new_bndr                    = setIdType bndr ty
 639     (other_alts, maybe_default) = findDefault alts
 640     Just default_rhs            = maybe_default
 641
 642 coreExprToStgFloat env
 643         (Case scrut@(Con (PrimOp ParOp) args) bndr alts) dem
 644   | maybeToBool maybe_default
 645   = coreExprToStgFloat env scrut (bdrDem bndr)  `thenUs` \ (binds, scrut') ->
 646     newEvaldLocalId env bndr                    `thenUs` \ (env', bndr') ->
 647     coreExprToStg env' default_rhs dem          `thenUs` \ default_rhs' ->
 648     returnUs (binds, mkStgCase scrut' bndr' (StgPrimAlts (idType bndr) [] (StgBindDefault default_rhs')))
 649   where
 650     (other_alts, maybe_default) = findDefault alts
 651     Just default_rhs            = maybe_default
 652 \end{code}
 653
 654 Now for normal case expressions...
 655
 656 \begin{code}
 657 coreExprToStgFloat env (Case scrut bndr alts) dem
 658   = coreExprToStgFloat env scrut (bdrDem bndr)  `thenUs` \ (binds, scrut') ->
 659     newEvaldLocalId env bndr                    `thenUs` \ (env', bndr') ->
 660     alts_to_stg env' (findDefault alts)         `thenUs` \ alts' ->
 661     returnUs (binds, mkStgCase scrut' bndr' alts')
 662   where
 663     scrut_ty  = idType bndr
 664     prim_case = isUnLiftedType scrut_ty && not (isUnboxedTupleType scrut_ty)
 665
 666     alts_to_stg env (alts, deflt)
 667       | prim_case
 668       = default_to_stg env deflt                `thenUs` \ deflt' ->
 669         mapUs (prim_alt_to_stg env) alts        `thenUs` \ alts' ->
 670         returnUs (StgPrimAlts scrut_ty alts' deflt')
 671
 672       | otherwise
 673       = default_to_stg env deflt                `thenUs` \ deflt' ->
 674         mapUs (alg_alt_to_stg env) alts         `thenUs` \ alts' ->
 675         returnUs (StgAlgAlts scrut_ty alts' deflt')
 676
 677     alg_alt_to_stg env (DataCon con, bs, rhs)
 678           = coreExprToStg env rhs dem   `thenUs` \ stg_rhs ->
 679             returnUs (con, filter isId bs, [ True | b <- bs ]{-bogus use mask-}, stg_rhs)
 680                 -- NB the filter isId.  Some of the binders may be
 681                 -- existential type variables, which STG doesn't care about
 682
 683     prim_alt_to_stg env (Literal lit, args, rhs)
 684           = ASSERT( null args )
 685             coreExprToStg env rhs dem   `thenUs` \ stg_rhs ->
 686             returnUs (lit, stg_rhs)
 687
 688     default_to_stg env Nothing
 689       = returnUs StgNoDefault
 690
 691     default_to_stg env (Just rhs)
 692       = coreExprToStg env rhs dem   `thenUs` \ stg_rhs ->
 693         returnUs (StgBindDefault stg_rhs)
 694                 -- The binder is used for prim cases and not otherwise
 695                 -- (hack for old code gen)
 696 \end{code}
 697
 698
 699 %************************************************************************
 700 %*                                                                      *
 701 \subsection[coreToStg-misc]{Miscellaneous helping functions}
 702 %*                                                                      *
 703 %************************************************************************
 704
 705 There's not anything interesting we can ASSERT about \tr{var} if it
 706 isn't in the StgEnv. (WDP 94/06)
 707
 708 \begin{code}
 709 stgLookup :: StgEnv -> Id -> Id
 710 stgLookup env var = case (lookupVarEnv env var) of
 711                       Nothing  -> var
 712                       Just var -> var
 713 \end{code}
 714
 715 Invent a fresh @Id@:
 716 \begin{code}
 717 newStgVar :: Type -> UniqSM Id
 718 newStgVar ty
 719  = getUniqueUs                  `thenUs` \ uniq ->
 720    returnUs (mkSysLocal SLIT("stg") uniq ty)
 721 \end{code}
 722
 723 \begin{code}
 724 -- we overload the demandInfo field of an Id to indicate whether the Id is definitely
 725 -- evaluated or not (i.e. whether it is a case binder).  This can be used to eliminate
 726 -- some redundant cases (c.f. dataToTag# above).
 727
 728 newEvaldLocalId env id
 729   = getUniqueUs                 `thenUs` \ uniq ->
 730     let
 731       id'     = modifyIdInfo (`setDemandInfo` wwStrict) (setIdUnique id uniq)
 732       new_env = extendVarEnv env id id'
 733     in
 734     returnUs (new_env, id')
 735
 736
 737 newLocalId TopLevel env id
 738   = returnUs (env, id)
 739   -- Don't clone top-level binders.  MkIface relies on their
 740   -- uniques staying the same, so it can snaffle IdInfo off the
 741   -- STG ids to put in interface files.
 742
 743 newLocalId NotTopLevel env id
 744   =     -- Local binder, give it a new unique Id.
 745     getUniqueUs                 `thenUs` \ uniq ->
 746     let
 747       id'     = setIdUnique id uniq
 748       new_env = extendVarEnv env id id'
 749     in
 750     returnUs (new_env, id')
 751
 752 newLocalIds :: TopLevelFlag -> StgEnv -> [Id] -> UniqSM (StgEnv, [Id])
 753 newLocalIds top_lev env []
 754   = returnUs (env, [])
 755 newLocalIds top_lev env (b:bs)
 756   = newLocalId top_lev env b    `thenUs` \ (env', b') ->
 757     newLocalIds top_lev env' bs `thenUs` \ (env'', bs') ->
 758     returnUs (env'', b':bs')
 759 \end{code}
 760
 761
 762 \begin{code}
 763 -- Stg doesn't have a lambda *expression*,
 764 deStgLam (StgLam ty bndrs body) = mkStgLamExpr ty bndrs body
 765 deStgLam expr                   = returnUs expr
 766
 767 mkStgLamExpr ty bndrs body
 768   = ASSERT( not (null bndrs) )
 769     newStgVar ty                `thenUs` \ fn ->
 770     returnUs (StgLet (StgNonRec fn lam_closure) (StgApp fn []))
 771   where
 772     lam_closure = StgRhsClosure noCCS
 773                                 stgArgOcc
 774                                 noSRT
 775                                 bOGUS_FVs
 776                                 ReEntrant       -- binders is non-empty
 777                                 bndrs
 778                                 body
 779
 780 mkStgBinds :: [StgFloatBind]
 781            -> StgExpr           -- *Can* be a StgLam
 782            -> UniqSM StgExpr    -- *Can* be a StgLam
 783
 784 mkStgBinds []     body = returnUs body
 785 mkStgBinds (b:bs) body
 786   = deStgLam body               `thenUs` \ body' ->
 787     go (b:bs) body'
 788   where
 789     go []     body = returnUs body
 790     go (b:bs) body = go bs body         `thenUs` \ body' ->
 791                      mkStgBind  b body'
 792
 793 -- The 'body' arg of mkStgBind can't be a StgLam
 794 mkStgBind NoBindF    body = returnUs body
 795 mkStgBind (RecF prs) body = returnUs (StgLet (StgRec prs) body)
 796
 797 mkStgBind (NonRecF bndr rhs dem floats) body
 798 #ifdef DEBUG
 799         -- We shouldn't get let or case of the form v=w
 800   = case rhs of
 801         StgApp v [] -> pprTrace "mkStgLet" (ppr bndr <+> ppr v)
 802                        (mk_stg_let bndr rhs dem floats body)
 803         other       ->  mk_stg_let bndr rhs dem floats body
 804
 805 mk_stg_let bndr rhs dem floats body
 806 #endif
 807   | isUnLiftedType bndr_ty                      -- Use a case/PrimAlts
 808   = ASSERT( not (isUnboxedTupleType bndr_ty) )
 809     mkStgBinds floats $
 810     mkStgCase rhs bndr (StgPrimAlts bndr_ty [] (StgBindDefault body))
 811
 812   | is_whnf
 813   = if is_strict then
 814         -- Strict let with WHNF rhs
 815         mkStgBinds floats $
 816         StgLet (StgNonRec bndr (exprToRhs dem rhs)) body
 817     else
 818         -- Lazy let with WHNF rhs; float until we find a strict binding
 819         let
 820             (floats_out, floats_in) = splitFloats floats
 821         in
 822         mkStgBinds floats_in rhs        `thenUs` \ new_rhs ->
 823         mkStgBinds floats_out $
 824         StgLet (StgNonRec bndr (exprToRhs dem new_rhs)) body
 825
 826   | otherwise   -- Not WHNF
 827   = if is_strict then
 828         -- Strict let with non-WHNF rhs
 829         mkStgBinds floats $
 830         mkStgCase rhs bndr (StgAlgAlts bndr_ty [] (StgBindDefault body))
 831     else
 832         -- Lazy let with non-WHNF rhs, so keep the floats in the RHS
 833         mkStgBinds floats rhs           `thenUs` \ new_rhs ->
 834         returnUs (StgLet (StgNonRec bndr (exprToRhs dem new_rhs)) body)
 835
 836   where
 837     bndr_ty   = idType bndr
 838     is_strict = isStrictDem dem
 839     is_whnf   = case rhs of
 840                   StgCon _ _ _ -> True
 841                   StgLam _ _ _ -> True
 842                   other        -> False
 843
 844 -- Split at the first strict binding
 845 splitFloats fs@(NonRecF _ _ dem _ : _)
 846   | isStrictDem dem = ([], fs)
 847
 848 splitFloats (f : fs) = case splitFloats fs of
 849                              (fs_out, fs_in) -> (f : fs_out, fs_in)
 850
 851 splitFloats [] = ([], [])
 852
 853
 854 mkStgCase scrut bndr alts
 855   = ASSERT( case scrut of { StgLam _ _ _ -> False; other -> True } )
 856         -- We should never find
 857         --      case (\x->e) of { ... }
 858         -- The simplifier eliminates such things
 859     StgCase scrut bOGUS_LVs bOGUS_LVs bndr noSRT alts
 860 \end{code}