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