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, mkVanillaId,
  24                           externallyVisibleId, setIdUnique, idName, getIdDemandInfo, setIdType
  25                         )
  26 import Var              ( Var, varType, modifyIdInfo )
  27 import IdInfo           ( setDemandInfo, StrictnessInfo(..), zapIdInfoForStg )
  28 import UsageSPUtils     ( primOpUsgTys )
  29 import DataCon          ( DataCon, dataConName, dataConId )
  30 import Demand           ( Demand, isStrict, wwStrict, wwLazy )
  31 import Name             ( Name, nameModule, isLocallyDefinedName, setNameUnique )
  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, seqType )
  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   = upd `seq`
 311     StgRhsClosure       noCCS           -- No cost centre (ToDo?)
 312                         stgArgOcc       -- safe
 313                         noSRT           -- figure out later
 314                         bOGUS_FVs
 315                         upd
 316                         []
 317                         expr
 318   where
 319     upd = if isOnceDem dem then SingleEntry else Updatable
 320                                 -- HA!  Paydirt for "dem"
 321
 322 isDynCon :: DataCon -> Bool
 323 isDynCon con = isDynName (dataConName con)
 324
 325 isDynArg :: StgArg -> Bool
 326 isDynArg (StgVarArg v)   = isDynName (idName v)
 327 isDynArg (StgConArg con) =
 328   case con of
 329     DataCon dc -> isDynCon dc
 330     Literal l  -> isLitLitLit l
 331     _          -> False
 332
 333 isDynName :: Name -> Bool
 334 isDynName nm =
 335       not (isLocallyDefinedName nm) &&
 336       isDynamicModule (nameModule nm)
 337 \end{code}
 338
 339
 340 %************************************************************************
 341 %*                                                                      *
 342 \subsection[coreToStg-atoms{Converting atoms}
 343 %*                                                                      *
 344 %************************************************************************
 345
 346 \begin{code}
 347 coreArgsToStg :: StgEnv -> [(CoreArg,RhsDemand)] -> UniqSM ([StgFloatBind], [StgArg])
 348 -- Arguments are all value arguments (tyargs already removed), paired with their demand
 349
 350 coreArgsToStg env []
 351   = returnUs ([], [])
 352
 353 coreArgsToStg env (ad:ads)
 354   = coreArgToStg env ad         `thenUs` \ (bs1, a') ->
 355     coreArgsToStg env ads       `thenUs` \ (bs2, as') ->
 356     returnUs (bs1 ++ bs2, a' : as')
 357
 358
 359 coreArgToStg :: StgEnv -> (CoreArg,RhsDemand) -> UniqSM ([StgFloatBind], StgArg)
 360 -- This is where we arrange that a non-trivial argument is let-bound
 361
 362 coreArgToStg env (arg,dem)
 363   = coreExprToStgFloat env arg dem              `thenUs` \ (floats, arg') ->
 364     case arg' of
 365         StgCon con [] _ -> returnUs (floats, StgConArg con)
 366         StgApp v []     -> returnUs (floats, StgVarArg v)
 367         other           -> newStgVar arg_ty     `thenUs` \ v ->
 368                            returnUs ([NonRecF v arg' dem floats], StgVarArg v)
 369   where
 370     arg_ty = coreExprType arg
 371 \end{code}
 372
 373
 374 %************************************************************************
 375 %*                                                                      *
 376 \subsection[coreToStg-exprs]{Converting core expressions}
 377 %*                                                                      *
 378 %************************************************************************
 379
 380 \begin{code}
 381 coreExprToStg :: StgEnv -> CoreExpr -> RhsDemand -> UniqSM StgExpr
 382 coreExprToStg env expr dem
 383   = coreExprToStgFloat env expr dem     `thenUs` \ (binds,stg_expr) ->
 384     mkStgBinds binds stg_expr           `thenUs` \ stg_expr' ->
 385     deStgLam stg_expr'
 386 \end{code}
 387
 388 %************************************************************************
 389 %*                                                                      *
 390 \subsubsection[coreToStg-let(rec)]{Let and letrec expressions}
 391 %*                                                                      *
 392 %************************************************************************
 393
 394 \begin{code}
 395 coreExprToStgFloat :: StgEnv -> CoreExpr
 396                    -> RhsDemand
 397                    -> UniqSM ([StgFloatBind], StgExpr)
 398 -- Transform an expression to STG. The demand on the expression is
 399 -- given by RhsDemand, and is solely used ot figure out the usage
 400 -- of constructor args: if the constructor is used once, then so are
 401 -- its arguments.  The strictness info in RhsDemand isn't used.
 402
 403 -- The StgExpr returned *can* be an StgLam
 404 \end{code}
 405
 406 Simple cases first
 407
 408 \begin{code}
 409 coreExprToStgFloat env (Var var) dem
 410   = returnUs ([], mkStgApp (stgLookup env var) [])
 411
 412 coreExprToStgFloat env (Let bind body) dem
 413   = coreBindToStg NotTopLevel env bind  `thenUs` \ (new_bind, new_env) ->
 414     coreExprToStgFloat new_env body dem `thenUs` \ (floats, stg_body) ->
 415     returnUs (new_bind:floats, stg_body)
 416 \end{code}
 417
 418 Convert core @scc@ expression directly to STG @scc@ expression.
 419
 420 \begin{code}
 421 coreExprToStgFloat env (Note (SCC cc) expr) dem
 422   = coreExprToStg env expr dem  `thenUs` \ stg_expr ->
 423     returnUs ([], StgSCC cc stg_expr)
 424
 425 coreExprToStgFloat env (Note other_note expr) dem
 426   = coreExprToStgFloat env expr dem
 427 \end{code}
 428
 429 \begin{code}
 430 coreExprToStgFloat env expr@(Type _) dem
 431   = pprPanic "coreExprToStgFloat: tyarg unexpected:" $ ppr expr
 432 \end{code}
 433
 434
 435 %************************************************************************
 436 %*                                                                      *
 437 \subsubsection[coreToStg-lambdas]{Lambda abstractions}
 438 %*                                                                      *
 439 %************************************************************************
 440
 441 \begin{code}
 442 coreExprToStgFloat env expr@(Lam _ _) dem
 443   = let
 444         expr_ty         = coreExprType expr
 445         (binders, body) = collectBinders expr
 446         id_binders      = filter isId binders
 447         body_dem        = trace "coreExprToStg: approximating body_dem in Lam"
 448                           safeDem
 449     in
 450     if null id_binders then     -- It was all type/usage binders; tossed
 451         coreExprToStgFloat env body dem
 452     else
 453         -- At least some value binders
 454     newLocalIds NotTopLevel env id_binders      `thenUs` \ (env', binders') ->
 455     coreExprToStgFloat env' body body_dem       `thenUs` \ (floats, stg_body) ->
 456     mkStgBinds floats stg_body                  `thenUs` \ stg_body' ->
 457
 458     case stg_body' of
 459       StgLam ty lam_bndrs lam_body ->
 460                 -- If the body reduced to a lambda too, join them up
 461           returnUs ([], mkStgLam expr_ty (binders' ++ lam_bndrs) lam_body)
 462
 463       other ->
 464                 -- Body didn't reduce to a lambda, so return one
 465           returnUs ([], mkStgLam expr_ty binders' stg_body')
 466 \end{code}
 467
 468
 469 %************************************************************************
 470 %*                                                                      *
 471 \subsubsection[coreToStg-applications]{Applications}
 472 %*                                                                      *
 473 %************************************************************************
 474
 475 \begin{code}
 476 coreExprToStgFloat env expr@(App _ _) dem
 477   = let
 478         (fun,rads,_,ss)       = collect_args expr
 479         ads                   = reverse rads
 480         final_ads | null ss   = ads
 481                   | otherwise = zap ads -- Too few args to satisfy strictness info
 482                                         -- so we have to ignore all the strictness info
 483                                         -- e.g. + (error "urk")
 484                                         -- Here, we can't evaluate the arg strictly,
 485                                         -- because this partial application might be seq'd
 486     in
 487     coreArgsToStg env final_ads         `thenUs` \ (arg_floats, stg_args) ->
 488
 489         -- Now deal with the function
 490     case (fun, stg_args) of
 491       (Var fun_id, _) ->        -- A function Id, so do an StgApp; it's ok if
 492                                 -- there are no arguments.
 493                             returnUs (arg_floats,
 494                                       mkStgApp (stgLookup env fun_id) stg_args)
 495
 496       (non_var_fun, []) ->      -- No value args, so recurse into the function
 497                             ASSERT( null arg_floats )
 498                             coreExprToStgFloat env non_var_fun dem
 499
 500       other ->  -- A non-variable applied to things; better let-bind it.
 501                 newStgVar (coreExprType fun)            `thenUs` \ fun_id ->
 502                 coreExprToStgFloat env fun onceDem      `thenUs` \ (fun_floats, stg_fun) ->
 503                 returnUs (NonRecF fun_id stg_fun onceDem fun_floats : arg_floats,
 504                           mkStgApp fun_id stg_args)
 505
 506   where
 507         -- Collect arguments and demands (*in reverse order*)
 508         -- collect_args e = (f, args_w_demands, ty, stricts)
 509         --  => e = f tys args,  (i.e. args are just the value args)
 510         --     e :: ty
 511         --     stricts is the leftover demands of e on its further args
 512         -- If stricts runs out, we zap all the demands in args_w_demands
 513         -- because partial applications are lazy
 514
 515     collect_args :: CoreExpr -> (CoreExpr, [(CoreExpr,RhsDemand)], Type, [Demand])
 516
 517     collect_args (Note (Coerce ty _) e) = let (the_fun,ads,_,ss) = collect_args e
 518                                           in  (the_fun,ads,ty,ss)
 519     collect_args (Note InlineCall    e) = collect_args e
 520     collect_args (Note (TermUsg _)   e) = collect_args e
 521
 522     collect_args (App fun (Type tyarg)) = let (the_fun,ads,fun_ty,ss) = collect_args fun
 523                                           in  (the_fun,ads,applyTy fun_ty tyarg,ss)
 524     collect_args (App fun arg)
 525         = (the_fun, (arg, mkDemTy ss1 arg_ty) : ads, res_ty, ss_rest)
 526         where
 527           (ss1, ss_rest)             = case ss of
 528                                          (ss1:ss_rest) -> (ss1, ss_rest)
 529                                          []            -> (wwLazy, [])
 530           (the_fun, ads, fun_ty, ss) = collect_args fun
 531           (arg_ty, res_ty)           = expectJust "coreExprToStgFloat:collect_args" $
 532                                        splitFunTy_maybe fun_ty
 533
 534     collect_args (Var v)
 535         = (Var v, [], idType v, stricts)
 536         where
 537           stricts = case getIdStrictness v of
 538                         StrictnessInfo demands _ -> demands
 539                         other                    -> repeat wwLazy
 540
 541     collect_args fun = (fun, [], coreExprType fun, repeat wwLazy)
 542
 543     -- "zap" nukes the strictness info for a partial application
 544     zap ads = [(arg, RhsDemand False once) | (arg, RhsDemand _ once) <- ads]
 545 \end{code}
 546
 547 %************************************************************************
 548 %*                                                                      *
 549 \subsubsection[coreToStg-con]{Constructors and primops}
 550 %*                                                                      *
 551 %************************************************************************
 552
 553 For data constructors, the demand on an argument is the demand on the
 554 constructor as a whole (see module UsageSPInf).  For primops, the
 555 demand is derived from the type of the primop.
 556
 557 If usage inference is off, we simply make all bindings updatable for
 558 speed.
 559
 560 \begin{code}
 561 coreExprToStgFloat env expr@(Con con args) dem
 562   = let
 563         expr_ty     = coreExprType expr
 564         (stricts,_) = conStrictness con
 565         onces = case con of
 566                     DEFAULT   -> panic "coreExprToStgFloat: DEFAULT"
 567
 568                     Literal _ -> ASSERT( null args' {-'cpp-} ) []
 569
 570                     DataCon c -> repeat (isOnceDem dem)
 571                                         -- HA!  This is the sole reason we propagate
 572                                         -- dem all the way down
 573
 574                     PrimOp  p -> let tyargs      = map (\ (Type ty) -> ty) $
 575                                                        takeWhile isTypeArg args
 576                                      (arg_tys,_) = primOpUsgTys p tyargs
 577                                  in  ASSERT( length arg_tys == length args' {-'cpp-} )
 578                                      -- primops always fully applied, so == not >=
 579                                      map isOnceTy arg_tys
 580
 581         dems' = zipWith mkDem stricts onces
 582         args' = filter isValArg args
 583     in
 584     coreArgsToStg env (zip args' dems')                  `thenUs` \ (arg_floats, stg_atoms) ->
 585
 586         -- YUK YUK: must unique if present
 587     (case con of
 588        PrimOp (CCallOp (Right _) a b c) -> getUniqueUs   `thenUs` \ u ->
 589                                            returnUs (PrimOp (CCallOp (Right u) a b c))
 590        _                                -> returnUs con
 591     )                                                     `thenUs` \ con' ->
 592
 593     returnUs (arg_floats, mkStgCon con' stg_atoms expr_ty)
 594 \end{code}
 595
 596
 597 %************************************************************************
 598 %*                                                                      *
 599 \subsubsection[coreToStg-cases]{Case expressions}
 600 %*                                                                      *
 601 %************************************************************************
 602
 603 First, two special cases.  We mangle cases involving
 604                 par# and seq#
 605 inthe scrutinee.
 606
 607 Up to this point, seq# will appear like this:
 608
 609           case seq# e of
 610                 0# -> seqError#
 611                 _  -> <stuff>
 612
 613 This code comes from an unfolding for 'seq' in Prelude.hs.
 614 The 0# branch is purely to bamboozle the strictness analyser.
 615 For example, if <stuff> is strict in x, and there was no seqError#
 616 branch, the strictness analyser would conclude that the whole expression
 617 was strict in x, and perhaps evaluate x first -- but that would be a DISASTER.
 618
 619 Now that the evaluation order is safe, we translate this into
 620
 621           case e of
 622                 _ -> ...
 623
 624 This used to be done in the post-simplification phase, but we need
 625 unfoldings involving seq# to appear unmangled in the interface file,
 626 hence we do this mangling here.
 627
 628 Similarly, par# has an unfolding in PrelConc.lhs that makes it show
 629 up like this:
 630
 631         case par# e of
 632           0# -> rhs
 633           _  -> parError#
 634
 635
 636     ==>
 637         case par# e of
 638           _ -> rhs
 639
 640 fork# isn't handled like this - it's an explicit IO operation now.
 641 The reason is that fork# returns a ThreadId#, which gets in the
 642 way of the above scheme.  And anyway, IO is the only guaranteed
 643 way to enforce ordering  --SDM.
 644
 645
 646 \begin{code}
 647 coreExprToStgFloat env
 648         (Case scrut@(Con (PrimOp SeqOp) [Type ty, e]) bndr alts) dem
 649   = coreExprToStgFloat env (Case e new_bndr [(DEFAULT,[],default_rhs)]) dem
 650   where
 651     new_bndr                    = setIdType bndr ty
 652     (other_alts, maybe_default) = findDefault alts
 653     Just default_rhs            = maybe_default
 654
 655 coreExprToStgFloat env
 656         (Case scrut@(Con (PrimOp ParOp) args) bndr alts) dem
 657   | maybeToBool maybe_default
 658   = coreExprToStgFloat env scrut (bdrDem bndr)  `thenUs` \ (binds, scrut') ->
 659     newEvaldLocalId env bndr                    `thenUs` \ (env', bndr') ->
 660     coreExprToStg env' default_rhs dem          `thenUs` \ default_rhs' ->
 661     returnUs (binds, mkStgCase scrut' bndr' (StgPrimAlts (idType bndr') [] (StgBindDefault default_rhs')))
 662   where
 663     (other_alts, maybe_default) = findDefault alts
 664     Just default_rhs            = maybe_default
 665 \end{code}
 666
 667 Now for normal case expressions...
 668
 669 \begin{code}
 670 coreExprToStgFloat env (Case scrut bndr alts) dem
 671   = coreExprToStgFloat env scrut (bdrDem bndr)  `thenUs` \ (binds, scrut') ->
 672     newEvaldLocalId env bndr                    `thenUs` \ (env', bndr') ->
 673     alts_to_stg env' (findDefault alts)         `thenUs` \ alts' ->
 674     returnUs (binds, mkStgCase scrut' bndr' alts')
 675   where
 676     scrut_ty  = idType bndr
 677     prim_case = isUnLiftedType scrut_ty && not (isUnboxedTupleType scrut_ty)
 678
 679     alts_to_stg env (alts, deflt)
 680       | prim_case
 681       = default_to_stg env deflt                `thenUs` \ deflt' ->
 682         mapUs (prim_alt_to_stg env) alts        `thenUs` \ alts' ->
 683         returnUs (mkStgPrimAlts scrut_ty alts' deflt')
 684
 685       | otherwise
 686       = default_to_stg env deflt                `thenUs` \ deflt' ->
 687         mapUs (alg_alt_to_stg env) alts         `thenUs` \ alts' ->
 688         returnUs (mkStgAlgAlts scrut_ty alts' deflt')
 689
 690     alg_alt_to_stg env (DataCon con, bs, rhs)
 691           = newLocalIds NotTopLevel env (filter isId bs)        `thenUs` \ (env', stg_bs) ->
 692             coreExprToStg env' rhs dem                          `thenUs` \ stg_rhs ->
 693             returnUs (con, stg_bs, [ True | b <- stg_bs ]{-bogus use mask-}, stg_rhs)
 694                 -- NB the filter isId.  Some of the binders may be
 695                 -- existential type variables, which STG doesn't care about
 696
 697     prim_alt_to_stg env (Literal lit, args, rhs)
 698           = ASSERT( null args )
 699             coreExprToStg env rhs dem   `thenUs` \ stg_rhs ->
 700             returnUs (lit, stg_rhs)
 701
 702     default_to_stg env Nothing
 703       = returnUs StgNoDefault
 704
 705     default_to_stg env (Just rhs)
 706       = coreExprToStg env rhs dem   `thenUs` \ stg_rhs ->
 707         returnUs (StgBindDefault stg_rhs)
 708                 -- The binder is used for prim cases and not otherwise
 709                 -- (hack for old code gen)
 710 \end{code}
 711
 712
 713 %************************************************************************
 714 %*                                                                      *
 715 \subsection[coreToStg-misc]{Miscellaneous helping functions}
 716 %*                                                                      *
 717 %************************************************************************
 718
 719 There's not anything interesting we can ASSERT about \tr{var} if it
 720 isn't in the StgEnv. (WDP 94/06)
 721
 722 \begin{code}
 723 stgLookup :: StgEnv -> Id -> Id
 724 stgLookup env var = case (lookupVarEnv env var) of
 725                       Nothing  -> var
 726                       Just var -> var
 727 \end{code}
 728
 729 Invent a fresh @Id@:
 730 \begin{code}
 731 newStgVar :: Type -> UniqSM Id
 732 newStgVar ty
 733  = getUniqueUs                  `thenUs` \ uniq ->
 734    seqType ty                   `seq`
 735    returnUs (mkSysLocal SLIT("stg") uniq ty)
 736 \end{code}
 737
 738 \begin{code}
 739 {-      Now redundant, I believe
 740 -- we overload the demandInfo field of an Id to indicate whether the Id is definitely
 741 -- evaluated or not (i.e. whether it is a case binder).  This can be used to eliminate
 742 -- some redundant cases (c.f. dataToTag# above).
 743
 744 newEvaldLocalId env id
 745   = getUniqueUs                 `thenUs` \ uniq ->
 746     let
 747       id'     = modifyIdInfo (`setDemandInfo` wwStrict) (setIdUnique id uniq)
 748       new_env = extendVarEnv env id id'
 749     in
 750     returnUs (new_env, id')
 751 -}
 752
 753 newEvaldLocalId env id = newLocalId NotTopLevel env id
 754
 755 newLocalId TopLevel env id
 756   -- Don't clone top-level binders.  MkIface relies on their
 757   -- uniques staying the same, so it can snaffle IdInfo off the
 758   -- STG ids to put in interface files.
 759   = let
 760       name = idName id
 761       ty   = idType id
 762     in
 763     name                `seq`
 764     seqType ty          `seq`
 765     returnUs (env, mkVanillaId name ty)
 766
 767
 768 newLocalId NotTopLevel env id
 769   =     -- Local binder, give it a new unique Id.
 770     getUniqueUs                 `thenUs` \ uniq ->
 771     let
 772       name    = idName id
 773       ty      = idType id
 774       new_id  = mkVanillaId (setNameUnique name uniq) ty
 775       new_env = extendVarEnv env id new_id
 776     in
 777     name                `seq`
 778     seqType ty          `seq`
 779     returnUs (new_env, new_id)
 780
 781 newLocalIds :: TopLevelFlag -> StgEnv -> [Id] -> UniqSM (StgEnv, [Id])
 782 newLocalIds top_lev env []
 783   = returnUs (env, [])
 784 newLocalIds top_lev env (b:bs)
 785   = newLocalId top_lev env b    `thenUs` \ (env', b') ->
 786     newLocalIds top_lev env' bs `thenUs` \ (env'', bs') ->
 787     returnUs (env'', b':bs')
 788 \end{code}
 789
 790
 791 %************************************************************************
 792 %*                                                                      *
 793 \subsection{Building STG syn}
 794 %*                                                                      *
 795 %************************************************************************
 796
 797 \begin{code}
 798 mkStgAlgAlts  ty alts deflt = seqType ty `seq` StgAlgAlts  ty alts deflt
 799 mkStgPrimAlts ty alts deflt = seqType ty `seq` StgPrimAlts ty alts deflt
 800 mkStgCon con args ty        = seqType ty `seq` StgCon con args ty
 801 mkStgLam ty bndrs body      = seqType ty `seq` StgLam ty bndrs body
 802
 803 mkStgApp :: Id -> [StgArg] -> StgExpr
 804 mkStgApp fn args = fn `seq` StgApp fn args
 805         -- Force the lookup
 806 \end{code}
 807
 808 \begin{code}
 809 -- Stg doesn't have a lambda *expression*,
 810 deStgLam (StgLam ty bndrs body) = mkStgLamExpr ty bndrs body
 811 deStgLam expr                   = returnUs expr
 812
 813 mkStgLamExpr ty bndrs body
 814   = ASSERT( not (null bndrs) )
 815     newStgVar ty                `thenUs` \ fn ->
 816     returnUs (StgLet (StgNonRec fn lam_closure) (mkStgApp fn []))
 817   where
 818     lam_closure = StgRhsClosure noCCS
 819                                 stgArgOcc
 820                                 noSRT
 821                                 bOGUS_FVs
 822                                 ReEntrant       -- binders is non-empty
 823                                 bndrs
 824                                 body
 825
 826 mkStgBinds :: [StgFloatBind]
 827            -> StgExpr           -- *Can* be a StgLam
 828            -> UniqSM StgExpr    -- *Can* be a StgLam
 829
 830 mkStgBinds []     body = returnUs body
 831 mkStgBinds (b:bs) body
 832   = deStgLam body               `thenUs` \ body' ->
 833     go (b:bs) body'
 834   where
 835     go []     body = returnUs body
 836     go (b:bs) body = go bs body         `thenUs` \ body' ->
 837                      mkStgBind  b body'
 838
 839 -- The 'body' arg of mkStgBind can't be a StgLam
 840 mkStgBind NoBindF    body = returnUs body
 841 mkStgBind (RecF prs) body = returnUs (StgLet (StgRec prs) body)
 842
 843 mkStgBind (NonRecF bndr rhs dem floats) body
 844 #ifdef DEBUG
 845         -- We shouldn't get let or case of the form v=w
 846   = case rhs of
 847         StgApp v [] -> pprTrace "mkStgLet" (ppr bndr <+> ppr v)
 848                        (mk_stg_let bndr rhs dem floats body)
 849         other       ->  mk_stg_let bndr rhs dem floats body
 850
 851 mk_stg_let bndr rhs dem floats body
 852 #endif
 853   | isUnLiftedType bndr_rep_ty                  -- Use a case/PrimAlts
 854   = ASSERT( not (isUnboxedTupleType bndr_rep_ty) )
 855     mkStgBinds floats $
 856     mkStgCase rhs bndr (StgPrimAlts bndr_rep_ty [] (StgBindDefault body))
 857
 858   | is_whnf
 859   = if is_strict then
 860         -- Strict let with WHNF rhs
 861         mkStgBinds floats $
 862         StgLet (StgNonRec bndr (exprToRhs dem NotTopLevel rhs)) body
 863     else
 864         -- Lazy let with WHNF rhs; float until we find a strict binding
 865         let
 866             (floats_out, floats_in) = splitFloats floats
 867         in
 868         mkStgBinds floats_in rhs        `thenUs` \ new_rhs ->
 869         mkStgBinds floats_out $
 870         StgLet (StgNonRec bndr (exprToRhs dem NotTopLevel new_rhs)) body
 871
 872   | otherwise   -- Not WHNF
 873   = if is_strict then
 874         -- Strict let with non-WHNF rhs
 875         mkStgBinds floats $
 876         mkStgCase rhs bndr (StgAlgAlts bndr_rep_ty [] (StgBindDefault body))
 877     else
 878         -- Lazy let with non-WHNF rhs, so keep the floats in the RHS
 879         mkStgBinds floats rhs           `thenUs` \ new_rhs ->
 880         returnUs (StgLet (StgNonRec bndr (exprToRhs dem NotTopLevel new_rhs)) body)
 881
 882   where
 883     bndr_rep_ty = repType (idType bndr)
 884     is_strict   = isStrictDem dem
 885     is_whnf     = case rhs of
 886                     StgCon _ _ _ -> True
 887                     StgLam _ _ _ -> True
 888                     other        -> False
 889
 890 -- Split at the first strict binding
 891 splitFloats fs@(NonRecF _ _ dem _ : _)
 892   | isStrictDem dem = ([], fs)
 893
 894 splitFloats (f : fs) = case splitFloats fs of
 895                              (fs_out, fs_in) -> (f : fs_out, fs_in)
 896
 897 splitFloats [] = ([], [])
 898
 899
 900 mkStgCase scrut bndr alts
 901   = ASSERT( case scrut of { StgLam _ _ _ -> False; other -> True } )
 902         -- We should never find
 903         --      case (\x->e) of { ... }
 904         -- The simplifier eliminates such things
 905     StgCase scrut bOGUS_LVs bOGUS_LVs bndr noSRT alts
 906 \end{code}