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