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