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