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