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, coreToStgExpr ) where
  14
  15 #include "HsVersions.h"
  16
  17 import CoreSyn          -- input
  18 import StgSyn           -- output
  19
  20 import CoreUtils        ( exprType )
  21 import SimplUtils       ( findDefault )
  22 import CostCentre       ( noCCS )
  23 import Id               ( Id, mkSysLocal, idType, idStrictness, isExportedId,
  24                           mkVanillaId, idName, idDemandInfo, idArity, setIdType,
  25                           idFlavour
  26                         )
  27 import IdInfo           ( StrictnessInfo(..), IdFlavour(..) )
  28 import DataCon          ( dataConWrapId, dataConTyCon )
  29 import TyCon            ( isAlgTyCon )
  30 import Demand           ( Demand, isStrict, wwLazy )
  31 import Name             ( setNameUnique )
  32 import VarEnv
  33 import PrimOp           ( PrimOp(..), setCCallUnique )
  34 import Type             ( isUnLiftedType, isUnboxedTupleType, Type, splitFunTy_maybe,
  35                           applyTy, repType, seqType, splitTyConApp_maybe, splitTyConApp,
  36                           splitRepFunTys, mkFunTys,
  37                           uaUTy, usOnce, usMany, isTyVarTy
  38                         )
  39 import UniqSupply       -- all of it, really
  40 import BasicTypes       ( TopLevelFlag(..), isNotTopLevel )
  41 import UniqSet          ( emptyUniqSet )
  42 import ErrUtils         ( showPass, dumpIfSet_dyn )
  43 import CmdLineOpts      ( DynFlags, DynFlag(..) )
  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
 147   =
 148 #ifdef USMANY
 149     opt_UsageSPOn &&  -- can't expect annotations if -fusagesp is off
 150 #endif
 151     once
 152   where
 153     u = uaUTy ty
 154     once | u == usOnce  = True
 155          | u == usMany  = False
 156          | isTyVarTy u  = False  -- if unknown at compile-time, is Top ie usMany
 157
 158 bdrDem :: Id -> RhsDemand
 159 bdrDem id = mkDem (idDemandInfo id) (isOnceTy (idType id))
 160
 161 safeDem, onceDem :: RhsDemand
 162 safeDem = RhsDemand False False  -- always safe to use this
 163 onceDem = RhsDemand False True   -- used at most once
 164 \end{code}
 165
 166 No free/live variable information is pinned on in this pass; it's added
 167 later.  For this pass
 168 we use @bOGUS_LVs@ and @bOGUS_FVs@ as placeholders.
 169
 170 When printing out the Stg we need non-bottom values in these
 171 locations.
 172
 173 \begin{code}
 174 bOGUS_LVs :: StgLiveVars
 175 bOGUS_LVs = emptyUniqSet
 176
 177 bOGUS_FVs :: [Id]
 178 bOGUS_FVs = []
 179 \end{code}
 180
 181 \begin{code}
 182 topCoreBindsToStg :: DynFlags -> [CoreBind] -> IO [StgBinding]
 183 topCoreBindsToStg dflags core_binds
 184   = do showPass dflags "Core2Stg"
 185        us <- mkSplitUniqSupply 'c'
 186        return (initUs_ us (coreBindsToStg emptyVarEnv core_binds))
 187   where
 188     coreBindsToStg :: StgEnv -> [CoreBind] -> UniqSM [StgBinding]
 189
 190     coreBindsToStg env [] = returnUs []
 191     coreBindsToStg env (b:bs)
 192       = coreBindToStg  TopLevel env b   `thenUs` \ (bind_spec, new_env) ->
 193         coreBindsToStg new_env bs       `thenUs` \ new_bs ->
 194         case bind_spec of
 195           NonRecF bndr rhs dem floats
 196                 -> ASSERT2( not (isStrictDem dem) &&
 197                             not (isUnLiftedType (idType bndr)),
 198                             ppr b )             -- No top-level cases!
 199
 200                    mkStgBinds floats rhs        `thenUs` \ new_rhs ->
 201                    returnUs (StgNonRec bndr (exprToRhs dem TopLevel new_rhs)
 202                              : new_bs)
 203                                         -- Keep all the floats inside...
 204                                         -- Some might be cases etc
 205                                         -- We might want to revisit this decision
 206
 207           RecF prs -> returnUs (StgRec prs : new_bs)
 208           NoBindF  -> pprTrace "topCoreBindsToStg" (ppr b) $
 209                       returnUs new_bs
 210 \end{code}
 211
 212 %************************************************************************
 213 %*                                                                      *
 214 \subsection[coreToStgExpr]{Converting an expression (for the interpreter)}
 215 %*                                                                      *
 216 %************************************************************************
 217
 218 \begin{code}
 219 coreToStgExpr :: DynFlags -> CoreExpr -> IO StgExpr
 220 coreToStgExpr dflags core_expr
 221   = do showPass dflags "Core2Stg"
 222        us <- mkSplitUniqSupply 'c'
 223        let stg_expr = initUs_ us (coreExprToStg emptyVarEnv core_expr)
 224        dumpIfSet_dyn dflags Opt_D_dump_stg "STG syntax:" (ppr stg_expr)
 225        return stg_expr
 226 \end{code}
 227
 228 %************************************************************************
 229 %*                                                                      *
 230 \subsection[coreToStg-binds]{Converting bindings}
 231 %*                                                                      *
 232 %************************************************************************
 233
 234 \begin{code}
 235 coreBindToStg :: TopLevelFlag -> StgEnv -> CoreBind -> UniqSM (StgFloatBind, StgEnv)
 236
 237 coreBindToStg top_lev env (NonRec binder rhs)
 238   = coreExprToStgFloat env rhs                  `thenUs` \ (floats, stg_rhs) ->
 239     case (floats, stg_rhs) of
 240         ([], StgApp var []) | not (isExportedId binder)
 241                      -> returnUs (NoBindF, extendVarEnv env binder var)
 242                 -- A trivial binding let x = y in ...
 243                 -- can arise if postSimplExpr floats a NoRep literal out
 244                 -- so it seems sensible to deal with it well.
 245                 -- But we don't want to discard exported things.  They can
 246                 -- occur; e.g. an exported user binding f = g
 247
 248         other -> newLocalId top_lev env binder          `thenUs` \ (new_env, new_binder) ->
 249                  returnUs (NonRecF new_binder stg_rhs dem floats, new_env)
 250   where
 251     dem = bdrDem binder
 252
 253
 254 coreBindToStg top_lev env (Rec pairs)
 255   = newLocalIds top_lev env binders     `thenUs` \ (env', binders') ->
 256     mapUs (do_rhs env') pairs           `thenUs` \ stg_rhss ->
 257     returnUs (RecF (binders' `zip` stg_rhss), env')
 258   where
 259     binders = map fst pairs
 260     do_rhs env (bndr,rhs) = coreExprToStgFloat env rhs          `thenUs` \ (floats, stg_expr) ->
 261                             mkStgBinds floats stg_expr          `thenUs` \ stg_expr' ->
 262                                 -- NB: stg_expr' might still be a StgLam (and we want that)
 263                             returnUs (exprToRhs (bdrDem bndr) top_lev stg_expr')
 264 \end{code}
 265
 266
 267 %************************************************************************
 268 %*                                                                      *
 269 \subsection[coreToStg-rhss]{Converting right hand sides}
 270 %*                                                                      *
 271 %************************************************************************
 272
 273 \begin{code}
 274 exprToRhs :: RhsDemand -> TopLevelFlag -> StgExpr -> StgRhs
 275 exprToRhs dem _ (StgLam _ bndrs body)
 276   = ASSERT( not (null bndrs) )
 277     StgRhsClosure noCCS
 278                   stgArgOcc
 279                   noSRT
 280                   bOGUS_FVs
 281                   ReEntrant     -- binders is non-empty
 282                   bndrs
 283                   body
 284
 285 {-
 286   We reject the following candidates for 'static constructor'dom:
 287
 288     - any dcon that takes a lit-lit as an arg.
 289     - [Win32 DLLs only]: any dcon that resides in a DLL
 290       (or takes as arg something that is.)
 291
 292   These constraints are necessary to ensure that the code
 293   generated in the end for the static constructors, which
 294   live in the data segment, remain valid - i.e., it has to
 295   be constant. For obvious reasons, that's hard to guarantee
 296   with lit-lits. The second case of a constructor referring
 297   to static closures hiding out in some DLL is an artifact
 298   of the way Win32 DLLs handle global DLL variables. A (data)
 299   symbol exported from a DLL  has to be accessed through a
 300   level of indirection at the site of use, so whereas
 301
 302      extern StgClosure y_closure;
 303      extern StgClosure z_closure;
 304      x = { ..., &y_closure, &z_closure };
 305
 306   is legal when the symbols are in scope at link-time, it is
 307   not when y_closure is in a DLL. So, any potential static
 308   closures that refers to stuff that's residing in a DLL
 309   will be put in an (updateable) thunk instead.
 310
 311   An alternative strategy is to support the generation of
 312   constructors (ala C++ static class constructors) which will
 313   then be run at load time to fix up static closures.
 314 -}
 315 exprToRhs dem toplev (StgConApp con args)
 316   | isNotTopLevel toplev || not (isDllConApp con args)
 317         -- isDllConApp checks for LitLit args too
 318   = StgRhsCon noCCS con args
 319
 320 exprToRhs dem toplev expr
 321   = upd `seq`
 322     StgRhsClosure       noCCS           -- No cost centre (ToDo?)
 323                         stgArgOcc       -- safe
 324                         noSRT           -- figure out later
 325                         bOGUS_FVs
 326                         upd
 327                         []
 328                         expr
 329   where
 330     upd = if isOnceDem dem
 331           then (if isNotTopLevel toplev
 332                 then SingleEntry              -- HA!  Paydirt for "dem"
 333                 else
 334 #ifdef DEBUG
 335                      trace "WARNING: SE CAFs unsupported, forcing UPD instead" $
 336 #endif
 337                      Updatable)
 338           else Updatable
 339         -- For now we forbid SingleEntry CAFs; they tickle the
 340         -- ASSERT in rts/Storage.c line 215 at newCAF() re mut_link,
 341         -- and I don't understand why.  There's only one SE_CAF (well,
 342         -- only one that tickled a great gaping bug in an earlier attempt
 343         -- at ClosureInfo.getEntryConvention) in the whole of nofib,
 344         -- specifically Main.lvl6 in spectral/cryptarithm2.
 345         -- So no great loss.  KSW 2000-07.
 346 \end{code}
 347
 348
 349 %************************************************************************
 350 %*                                                                      *
 351 \subsection[coreToStg-atoms{Converting atoms}
 352 %*                                                                      *
 353 %************************************************************************
 354
 355 \begin{code}
 356 coreArgsToStg :: StgEnv -> [(CoreArg,RhsDemand)] -> UniqSM ([StgFloatBind], [StgArg])
 357 -- Arguments are all value arguments (tyargs already removed), paired with their demand
 358
 359 coreArgsToStg env []
 360   = returnUs ([], [])
 361
 362 coreArgsToStg env (ad:ads)
 363   = coreArgToStg env ad         `thenUs` \ (bs1, a') ->
 364     coreArgsToStg env ads       `thenUs` \ (bs2, as') ->
 365     returnUs (bs1 ++ bs2, a' : as')
 366
 367
 368 coreArgToStg :: StgEnv -> (CoreArg,RhsDemand) -> UniqSM ([StgFloatBind], StgArg)
 369 -- This is where we arrange that a non-trivial argument is let-bound
 370
 371 coreArgToStg env (arg,dem)
 372   = coreExprToStgFloat env arg          `thenUs` \ (floats, arg') ->
 373     case arg' of
 374         StgApp v []      -> returnUs (floats, StgVarArg v)
 375         StgLit lit       -> returnUs (floats, StgLitArg lit)
 376
 377         StgConApp con [] -> returnUs (floats, StgVarArg (dataConWrapId con))
 378                 -- A nullary constructor can be replaced with
 379                 -- a ``call'' to its wrapper
 380
 381         other            -> newStgVar arg_ty    `thenUs` \ v ->
 382                             returnUs ([NonRecF v arg' dem floats], StgVarArg v)
 383   where
 384     arg_ty = exprType arg
 385 \end{code}
 386
 387
 388 %************************************************************************
 389 %*                                                                      *
 390 \subsection[coreToStg-exprs]{Converting core expressions}
 391 %*                                                                      *
 392 %************************************************************************
 393
 394 \begin{code}
 395 coreExprToStg :: StgEnv -> CoreExpr -> UniqSM StgExpr
 396 coreExprToStg env expr
 397   = coreExprToStgFloat env expr         `thenUs` \ (binds,stg_expr) ->
 398     mkStgBinds binds stg_expr           `thenUs` \ stg_expr' ->
 399     deStgLam stg_expr'
 400 \end{code}
 401
 402 %************************************************************************
 403 %*                                                                      *
 404 \subsubsection[coreToStg-let(rec)]{Let and letrec expressions}
 405 %*                                                                      *
 406 %************************************************************************
 407
 408 \begin{code}
 409 coreExprToStgFloat :: StgEnv -> CoreExpr
 410                    -> UniqSM ([StgFloatBind], StgExpr)
 411 -- Transform an expression to STG.  The 'floats' are
 412 -- any bindings we had to create for function arguments.
 413 \end{code}
 414
 415 Simple cases first
 416
 417 \begin{code}
 418 coreExprToStgFloat env (Var var)
 419   = mkStgApp env var [] (idType var)    `thenUs` \ app ->
 420     returnUs ([], app)
 421
 422 coreExprToStgFloat env (Lit lit)
 423   = returnUs ([], StgLit lit)
 424
 425 coreExprToStgFloat env (Let bind body)
 426   = coreBindToStg NotTopLevel env bind  `thenUs` \ (new_bind, new_env) ->
 427     coreExprToStgFloat new_env body     `thenUs` \ (floats, stg_body) ->
 428     returnUs (new_bind:floats, stg_body)
 429 \end{code}
 430
 431 Convert core @scc@ expression directly to STG @scc@ expression.
 432
 433 \begin{code}
 434 coreExprToStgFloat env (Note (SCC cc) expr)
 435   = coreExprToStg env expr      `thenUs` \ stg_expr ->
 436     returnUs ([], StgSCC cc stg_expr)
 437
 438 coreExprToStgFloat env (Note other_note expr)
 439   = coreExprToStgFloat env expr
 440 \end{code}
 441
 442 \begin{code}
 443 coreExprToStgFloat env expr@(Type _)
 444   = pprPanic "coreExprToStgFloat: tyarg unexpected:" $ ppr expr
 445 \end{code}
 446
 447
 448 %************************************************************************
 449 %*                                                                      *
 450 \subsubsection[coreToStg-lambdas]{Lambda abstractions}
 451 %*                                                                      *
 452 %************************************************************************
 453
 454 \begin{code}
 455 coreExprToStgFloat env expr@(Lam _ _)
 456   = let
 457         expr_ty         = exprType expr
 458         (binders, body) = collectBinders expr
 459         id_binders      = filter isId binders
 460     in
 461     if null id_binders then     -- It was all type binders; tossed
 462         coreExprToStgFloat env body
 463     else
 464         -- At least some value binders
 465     newLocalIds NotTopLevel env id_binders      `thenUs` \ (env', binders') ->
 466     coreExprToStgFloat env' body                `thenUs` \ (floats, stg_body) ->
 467     mkStgBinds floats stg_body                  `thenUs` \ stg_body' ->
 468
 469     case stg_body' of
 470       StgLam ty lam_bndrs lam_body ->
 471                 -- If the body reduced to a lambda too, join them up
 472           returnUs ([], mkStgLam expr_ty (binders' ++ lam_bndrs) lam_body)
 473
 474       other ->
 475                 -- Body didn't reduce to a lambda, so return one
 476           returnUs ([], mkStgLam expr_ty binders' stg_body')
 477 \end{code}
 478
 479
 480 %************************************************************************
 481 %*                                                                      *
 482 \subsubsection[coreToStg-applications]{Applications}
 483 %*                                                                      *
 484 %************************************************************************
 485
 486 \begin{code}
 487 coreExprToStgFloat env expr@(App _ _)
 488   = let
 489         (fun,rads,ty,ss)      = collect_args expr
 490         ads                   = reverse rads
 491         final_ads | null ss   = ads
 492                   | otherwise = zap ads -- Too few args to satisfy strictness info
 493                                         -- so we have to ignore all the strictness info
 494                                         -- e.g. + (error "urk")
 495                                         -- Here, we can't evaluate the arg strictly,
 496                                         -- because this partial application might be seq'd
 497     in
 498     coreArgsToStg env final_ads         `thenUs` \ (arg_floats, stg_args) ->
 499
 500         -- Now deal with the function
 501     case (fun, stg_args) of
 502       (Var fn_id, _) ->         -- A function Id, so do an StgApp; it's ok if
 503                                 -- there are no arguments.
 504                             mkStgApp env fn_id stg_args ty      `thenUs` \ app ->
 505                             returnUs (arg_floats, app)
 506
 507       (non_var_fun, []) ->      -- No value args, so recurse into the function
 508                             ASSERT( null arg_floats )
 509                             coreExprToStgFloat env non_var_fun
 510
 511       other ->  -- A non-variable applied to things; better let-bind it.
 512                 newStgVar (exprType fun)                `thenUs` \ fn_id ->
 513                 coreExprToStgFloat env fun              `thenUs` \ (fun_floats, stg_fun) ->
 514                 mkStgApp env fn_id stg_args ty          `thenUs` \ app ->
 515                 returnUs (NonRecF fn_id stg_fun onceDem fun_floats : arg_floats,
 516                           app)
 517
 518   where
 519         -- Collect arguments and demands (*in reverse order*)
 520         -- collect_args e = (f, args_w_demands, ty, stricts)
 521         --  => e = f tys args,  (i.e. args are just the value args)
 522         --     e :: ty
 523         --     stricts is the leftover demands of e on its further args
 524         -- If stricts runs out, we zap all the demands in args_w_demands
 525         -- because partial applications are lazy
 526
 527     collect_args :: CoreExpr -> (CoreExpr, [(CoreExpr,RhsDemand)], Type, [Demand])
 528
 529     collect_args (Note (Coerce ty _) e) = let (the_fun,ads,_,ss) = collect_args e
 530                                           in  (the_fun,ads,ty,ss)
 531     collect_args (Note InlineCall    e) = collect_args e
 532
 533     collect_args (App fun (Type tyarg)) = let (the_fun,ads,fun_ty,ss) = collect_args fun
 534                                           in  (the_fun,ads,applyTy fun_ty tyarg,ss)
 535     collect_args (App fun arg)
 536         = (the_fun, (arg, mkDemTy ss1 arg_ty) : ads, res_ty, ss_rest)
 537         where
 538           (ss1, ss_rest)             = case ss of
 539                                          (ss1:ss_rest) -> (ss1, ss_rest)
 540                                          []            -> (wwLazy, [])
 541           (the_fun, ads, fun_ty, ss) = collect_args fun
 542           (arg_ty, res_ty)           = expectJust "coreExprToStgFloat:collect_args" $
 543                                        splitFunTy_maybe fun_ty
 544
 545     collect_args (Var v)
 546         = (Var v, [], idType v, stricts)
 547         where
 548           stricts = case idStrictness v of
 549                         StrictnessInfo demands _ -> demands
 550                         other                    -> repeat wwLazy
 551
 552     collect_args fun = (fun, [], exprType fun, repeat wwLazy)
 553
 554     -- "zap" nukes the strictness info for a partial application
 555     zap ads = [(arg, RhsDemand False once) | (arg, RhsDemand _ once) <- ads]
 556 \end{code}
 557
 558
 559 %************************************************************************
 560 %*                                                                      *
 561 \subsubsection[coreToStg-cases]{Case expressions}
 562 %*                                                                      *
 563 %************************************************************************
 564
 565 \begin{code}
 566 coreExprToStgFloat env (Case scrut bndr alts)
 567   = coreExprToStgFloat env scrut                `thenUs` \ (binds, scrut') ->
 568     newLocalId NotTopLevel env bndr             `thenUs` \ (env', bndr') ->
 569     alts_to_stg env' (findDefault alts)         `thenUs` \ alts' ->
 570     mkStgCase scrut' bndr' alts'                `thenUs` \ expr' ->
 571     returnUs (binds, expr')
 572   where
 573     scrut_ty  = idType bndr
 574     prim_case = isUnLiftedType scrut_ty && not (isUnboxedTupleType scrut_ty)
 575
 576     alts_to_stg env (alts, deflt)
 577       | prim_case
 578       = default_to_stg env deflt                `thenUs` \ deflt' ->
 579         mapUs (prim_alt_to_stg env) alts        `thenUs` \ alts' ->
 580         returnUs (mkStgPrimAlts scrut_ty alts' deflt')
 581
 582       | otherwise
 583       = default_to_stg env deflt                `thenUs` \ deflt' ->
 584         mapUs (alg_alt_to_stg env) alts         `thenUs` \ alts' ->
 585         returnUs (mkStgAlgAlts scrut_ty alts' deflt')
 586
 587     alg_alt_to_stg env (DataAlt con, bs, rhs)
 588           = newLocalIds NotTopLevel env (filter isId bs)        `thenUs` \ (env', stg_bs) ->
 589             coreExprToStg env' rhs                              `thenUs` \ stg_rhs ->
 590             returnUs (con, stg_bs, [ True | b <- stg_bs ]{-bogus use mask-}, stg_rhs)
 591                 -- NB the filter isId.  Some of the binders may be
 592                 -- existential type variables, which STG doesn't care about
 593
 594     prim_alt_to_stg env (LitAlt lit, args, rhs)
 595           = ASSERT( null args )
 596             coreExprToStg env rhs       `thenUs` \ stg_rhs ->
 597             returnUs (lit, stg_rhs)
 598
 599     default_to_stg env Nothing
 600       = returnUs StgNoDefault
 601
 602     default_to_stg env (Just rhs)
 603       = coreExprToStg env rhs   `thenUs` \ stg_rhs ->
 604         returnUs (StgBindDefault stg_rhs)
 605 \end{code}
 606
 607
 608 %************************************************************************
 609 %*                                                                      *
 610 \subsection[coreToStg-misc]{Miscellaneous helping functions}
 611 %*                                                                      *
 612 %************************************************************************
 613
 614 There's not anything interesting we can ASSERT about \tr{var} if it
 615 isn't in the StgEnv. (WDP 94/06)
 616
 617 Invent a fresh @Id@:
 618 \begin{code}
 619 newStgVar :: Type -> UniqSM Id
 620 newStgVar ty
 621  = getUniqueUs                  `thenUs` \ uniq ->
 622    seqType ty                   `seq`
 623    returnUs (mkSysLocal SLIT("stg") uniq ty)
 624 \end{code}
 625
 626 \begin{code}
 627 newLocalId TopLevel env id
 628   -- Don't clone top-level binders.  MkIface relies on their
 629   -- uniques staying the same, so it can snaffle IdInfo off the
 630   -- STG ids to put in interface files.
 631   = let
 632       name = idName id
 633       ty   = idType id
 634     in
 635     name                `seq`
 636     seqType ty          `seq`
 637     returnUs (env, mkVanillaId name ty)
 638
 639
 640 newLocalId NotTopLevel env id
 641   =     -- Local binder, give it a new unique Id.
 642     getUniqueUs                 `thenUs` \ uniq ->
 643     let
 644       name    = idName id
 645       ty      = idType id
 646       new_id  = mkVanillaId (setNameUnique name uniq) ty
 647       new_env = extendVarEnv env id new_id
 648     in
 649     name                `seq`
 650     seqType ty          `seq`
 651     returnUs (new_env, new_id)
 652
 653 newLocalIds :: TopLevelFlag -> StgEnv -> [Id] -> UniqSM (StgEnv, [Id])
 654 newLocalIds top_lev env []
 655   = returnUs (env, [])
 656 newLocalIds top_lev env (b:bs)
 657   = newLocalId top_lev env b    `thenUs` \ (env', b') ->
 658     newLocalIds top_lev env' bs `thenUs` \ (env'', bs') ->
 659     returnUs (env'', b':bs')
 660 \end{code}
 661
 662
 663 %************************************************************************
 664 %*                                                                      *
 665 \subsection{Building STG syn}
 666 %*                                                                      *
 667 %************************************************************************
 668
 669 \begin{code}
 670 -- There are two things going on in mkStgAlgAlts
 671 -- a)   We pull out the type constructor for the case, from the data
 672 --      constructor, if there is one.  See notes with the StgAlgAlts data type
 673 -- b)   We force the type constructor to avoid space leaks
 674
 675 mkStgAlgAlts ty alts deflt
 676   = case alts of
 677                 -- Get the tycon from the data con
 678         (dc, _, _, _):_ -> StgAlgAlts (Just (dataConTyCon dc)) alts deflt
 679
 680                 -- Otherwise just do your best
 681         [] -> case splitTyConApp_maybe (repType ty) of
 682                 Just (tc,_) | isAlgTyCon tc -> StgAlgAlts (Just tc) alts deflt
 683                 other                       -> StgAlgAlts Nothing alts deflt
 684
 685 mkStgPrimAlts ty alts deflt
 686   = case splitTyConApp ty of
 687         (tc,_) -> StgPrimAlts tc alts deflt
 688
 689 mkStgLam ty bndrs body = seqType ty `seq` StgLam ty bndrs body
 690
 691 mkStgApp :: StgEnv -> Id -> [StgArg] -> Type -> UniqSM StgExpr
 692         -- The type is the type of the entire application
 693 mkStgApp env fn args ty
 694  = case idFlavour fn_alias of
 695       DataConId dc
 696         -> saturate fn_alias args ty    $ \ args' ty' ->
 697            returnUs (StgConApp dc args')
 698
 699       PrimOpId (CCallOp ccall)
 700                 -- Sigh...make a guaranteed unique name for a dynamic ccall
 701                 -- Done here, not earlier, because it's a code-gen thing
 702         -> saturate fn_alias args ty    $ \ args' ty' ->
 703            getUniqueUs                  `thenUs` \ uniq ->
 704            let ccall' = setCCallUnique ccall uniq in
 705            returnUs (StgPrimApp (CCallOp ccall') args' ty')
 706
 707
 708       PrimOpId op
 709         -> saturate fn_alias args ty    $ \ args' ty' ->
 710            returnUs (StgPrimApp op args' ty')
 711
 712       other -> returnUs (StgApp fn_alias args)
 713                         -- Force the lookup
 714   where
 715     fn_alias = case (lookupVarEnv env fn) of    -- In case it's been cloned
 716                       Nothing  -> fn
 717                       Just fn' -> fn'
 718
 719 saturate :: Id -> [StgArg] -> Type -> ([StgArg] -> Type -> UniqSM StgExpr) -> UniqSM StgExpr
 720         -- The type should be the type of (id args)
 721 saturate fn args ty thing_inside
 722   | excess_arity == 0   -- Saturated, so nothing to do
 723   = thing_inside args ty
 724
 725   | otherwise   -- An unsaturated constructor or primop; eta expand it
 726   = ASSERT2( excess_arity > 0 && excess_arity <= length arg_tys,
 727              ppr fn <+> ppr args <+> ppr excess_arity <+> parens (ppr ty) <+> ppr arg_tys )
 728     mapUs newStgVar extra_arg_tys                               `thenUs` \ arg_vars ->
 729     thing_inside (args ++ map StgVarArg arg_vars) final_res_ty  `thenUs` \ body ->
 730     returnUs (StgLam ty arg_vars body)
 731   where
 732     fn_arity            = idArity fn
 733     excess_arity        = fn_arity - length args
 734     (arg_tys, res_ty)   = splitRepFunTys ty
 735     extra_arg_tys       = take excess_arity arg_tys
 736     final_res_ty        = mkFunTys (drop excess_arity arg_tys) res_ty
 737 \end{code}
 738
 739 \begin{code}
 740 -- Stg doesn't have a lambda *expression*
 741 deStgLam (StgLam ty bndrs body)
 742         -- Try for eta reduction
 743   = ASSERT( not (null bndrs) )
 744     case eta body of
 745         Just e  ->      -- Eta succeeded
 746                     returnUs e
 747
 748         Nothing ->      -- Eta failed, so let-bind the lambda
 749                     newStgVar ty                `thenUs` \ fn ->
 750                     returnUs (StgLet (StgNonRec fn lam_closure) (StgApp fn []))
 751   where
 752     lam_closure = StgRhsClosure noCCS
 753                                 stgArgOcc
 754                                 noSRT
 755                                 bOGUS_FVs
 756                                 ReEntrant       -- binders is non-empty
 757                                 bndrs
 758                                 body
 759
 760     eta (StgApp f args)
 761         | n_remaining >= 0 &&
 762           and (zipWith ok bndrs last_args) &&
 763           notInExpr bndrs remaining_expr
 764         = Just remaining_expr
 765         where
 766           remaining_expr = StgApp f remaining_args
 767           (remaining_args, last_args) = splitAt n_remaining args
 768           n_remaining = length args - length bndrs
 769
 770     eta (StgLet bind@(StgNonRec b r) body)
 771         | notInRhs bndrs r = case eta body of
 772                                 Just e -> Just (StgLet bind e)
 773                                 Nothing -> Nothing
 774
 775     eta _ = Nothing
 776
 777     ok bndr (StgVarArg arg) = bndr == arg
 778     ok bndr other           = False
 779
 780 deStgLam expr = returnUs expr
 781
 782
 783 --------------------------------------------------
 784 notInExpr :: [Id] -> StgExpr -> Bool
 785 notInExpr vs (StgApp f args)               = notInId vs f && notInArgs vs args
 786 notInExpr vs (StgLet (StgNonRec b r) body) = notInRhs vs r && notInExpr vs body
 787 notInExpr vs other                         = False      -- Safe
 788
 789 notInRhs :: [Id] -> StgRhs -> Bool
 790 notInRhs vs (StgRhsCon _ _ args)             = notInArgs vs args
 791 notInRhs vs (StgRhsClosure _ _ _ _ _ _ body) = notInExpr vs body
 792         -- Conservative: we could delete the binders from vs, but
 793         -- cloning means this will never help
 794
 795 notInArgs :: [Id] -> [StgArg] -> Bool
 796 notInArgs vs args = all ok args
 797                   where
 798                     ok (StgVarArg v) = notInId vs v
 799                     ok (StgLitArg l) = True
 800
 801 notInId :: [Id] -> Id -> Bool
 802 notInId vs v = not (v `elem` vs)
 803
 804
 805
 806 mkStgBinds :: [StgFloatBind]
 807            -> StgExpr           -- *Can* be a StgLam
 808            -> UniqSM StgExpr    -- *Can* be a StgLam
 809
 810 mkStgBinds []     body = returnUs body
 811 mkStgBinds (b:bs) body
 812   = deStgLam body               `thenUs` \ body' ->
 813     go (b:bs) body'
 814   where
 815     go []     body = returnUs body
 816     go (b:bs) body = go bs body         `thenUs` \ body' ->
 817                      mkStgBind  b body'
 818
 819 -- The 'body' arg of mkStgBind can't be a StgLam
 820 mkStgBind NoBindF    body = returnUs body
 821 mkStgBind (RecF prs) body = returnUs (StgLet (StgRec prs) body)
 822
 823 mkStgBind (NonRecF bndr rhs dem floats) body
 824 #ifdef DEBUG
 825         -- We shouldn't get let or case of the form v=w
 826   = case rhs of
 827         StgApp v [] -> pprTrace "mkStgLet" (ppr bndr <+> ppr v)
 828                        (mk_stg_let bndr rhs dem floats body)
 829         other       ->  mk_stg_let bndr rhs dem floats body
 830
 831 mk_stg_let bndr rhs dem floats body
 832 #endif
 833   | isUnLiftedType bndr_rep_ty                  -- Use a case/PrimAlts
 834   = ASSERT( not (isUnboxedTupleType bndr_rep_ty) )
 835     mkStgCase rhs bndr (mkStgPrimAlts bndr_rep_ty [] (StgBindDefault body))     `thenUs` \ expr' ->
 836     mkStgBinds floats expr'
 837
 838   | is_whnf
 839   = if is_strict then
 840         -- Strict let with WHNF rhs
 841         mkStgBinds floats $
 842         StgLet (StgNonRec bndr (exprToRhs dem NotTopLevel rhs)) body
 843     else
 844         -- Lazy let with WHNF rhs; float until we find a strict binding
 845         let
 846             (floats_out, floats_in) = splitFloats floats
 847         in
 848         mkStgBinds floats_in rhs        `thenUs` \ new_rhs ->
 849         mkStgBinds floats_out $
 850         StgLet (StgNonRec bndr (exprToRhs dem NotTopLevel new_rhs)) body
 851
 852   | otherwise   -- Not WHNF
 853   = if is_strict then
 854         -- Strict let with non-WHNF rhs
 855         mkStgCase rhs bndr (mkStgAlgAlts bndr_rep_ty [] (StgBindDefault body))  `thenUs` \ expr' ->
 856         mkStgBinds floats expr'
 857     else
 858         -- Lazy let with non-WHNF rhs, so keep the floats in the RHS
 859         mkStgBinds floats rhs           `thenUs` \ new_rhs ->
 860         returnUs (StgLet (StgNonRec bndr (exprToRhs dem NotTopLevel new_rhs)) body)
 861
 862   where
 863     bndr_rep_ty = repType (idType bndr)
 864     is_strict   = isStrictDem dem
 865     is_whnf     = case rhs of
 866                     StgConApp _ _ -> True
 867                     StgLam _ _ _  -> True
 868                     other         -> False
 869
 870 -- Split at the first strict binding
 871 splitFloats fs@(NonRecF _ _ dem _ : _)
 872   | isStrictDem dem = ([], fs)
 873
 874 splitFloats (f : fs) = case splitFloats fs of
 875                              (fs_out, fs_in) -> (f : fs_out, fs_in)
 876
 877 splitFloats [] = ([], [])
 878 \end{code}
 879
 880
 881 Making an STG case
 882 ~~~~~~~~~~~~~~~~~~
 883
 884 First, two special cases.  We mangle cases involving
 885                 par# and seq#
 886 inthe scrutinee.
 887
 888 Up to this point, seq# will appear like this:
 889
 890           case seq# e of
 891                 0# -> seqError#
 892                 _  -> <stuff>
 893
 894 This code comes from an unfolding for 'seq' in Prelude.hs.
 895 The 0# branch is purely to bamboozle the strictness analyser.
 896 For example, if <stuff> is strict in x, and there was no seqError#
 897 branch, the strictness analyser would conclude that the whole expression
 898 was strict in x, and perhaps evaluate x first -- but that would be a DISASTER.
 899
 900 Now that the evaluation order is safe, we translate this into
 901
 902           case e of
 903                 _ -> ...
 904
 905 This used to be done in the post-simplification phase, but we need
 906 unfoldings involving seq# to appear unmangled in the interface file,
 907 hence we do this mangling here.
 908
 909 Similarly, par# has an unfolding in PrelConc.lhs that makes it show
 910 up like this:
 911
 912         case par# e of
 913           0# -> rhs
 914           _  -> parError#
 915
 916
 917     ==>
 918         case par# e of
 919           _ -> rhs
 920
 921 fork# isn't handled like this - it's an explicit IO operation now.
 922 The reason is that fork# returns a ThreadId#, which gets in the
 923 way of the above scheme.  And anyway, IO is the only guaranteed
 924 way to enforce ordering  --SDM.
 925
 926
 927 \begin{code}
 928 -- Discard alernatives in case (par# ..) of
 929 mkStgCase scrut@(StgPrimApp ParOp _ _) bndr
 930           (StgPrimAlts tycon _ deflt@(StgBindDefault _))
 931   = returnUs (StgCase scrut bOGUS_LVs bOGUS_LVs bndr noSRT (StgPrimAlts tycon [] deflt))
 932
 933 mkStgCase (StgPrimApp SeqOp [scrut] _) bndr
 934           (StgPrimAlts _ _ deflt@(StgBindDefault rhs))
 935   = mkStgCase scrut_expr new_bndr new_alts
 936   where
 937     new_alts | isUnLiftedType scrut_ty = WARN( True, text "mkStgCase" ) mkStgPrimAlts scrut_ty [] deflt
 938              | otherwise               = mkStgAlgAlts scrut_ty [] deflt
 939     scrut_ty = stgArgType scrut
 940     new_bndr = setIdType bndr scrut_ty
 941         -- NB:  SeqOp :: forall a. a -> Int#
 942         -- So bndr has type Int#
 943         -- But now we are going to scrutinise the SeqOp's argument directly,
 944         -- so we must change the type of the case binder to match that
 945         -- of the argument expression e.
 946
 947     scrut_expr = case scrut of
 948                    StgVarArg v -> StgApp v []
 949                    -- Others should not happen because
 950                    -- seq of a value should have disappeared
 951                    StgLitArg l -> WARN( True, text "seq on" <+> ppr l ) StgLit l
 952
 953 mkStgCase scrut bndr alts
 954   = deStgLam scrut      `thenUs` \ scrut' ->
 955         -- It is (just) possible to get a lambda as a srutinee here
 956         -- Namely: fromDyn (toDyn ((+1)::Int->Int)) False)
 957         -- gives:       case ...Bool == Int->Int... of
 958         --                 True -> case coerce Bool (\x -> + 1 x) of
 959         --                              True -> ...
 960         --                              False -> ...
 961         --                 False -> ...
 962         -- The True branch of the outer case will never happen, of course.
 963
 964     returnUs (StgCase scrut' bOGUS_LVs bOGUS_LVs bndr noSRT alts)
 965 \end{code}