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