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         -- The type should be the type of (id args)
 681 saturate fn args ty thing_inside
 682   | excess_arity == 0   -- Saturated, so nothing to do
 683   = thing_inside args ty
 684
 685   | otherwise   -- An unsaturated constructor or primop; eta expand it
 686   = ASSERT2( excess_arity > 0 && excess_arity <= length arg_tys,
 687              ppr fn <+> ppr args <+> ppr excess_arity <+> parens (ppr ty) <+> ppr arg_tys )
 688     mapUs newStgVar extra_arg_tys                               `thenUs` \ arg_vars ->
 689     thing_inside (args ++ map StgVarArg arg_vars) final_res_ty  `thenUs` \ body ->
 690     returnUs (StgLam ty arg_vars body)
 691   where
 692     fn_arity            = idArity fn
 693     excess_arity        = fn_arity - length args
 694     (arg_tys, res_ty)   = splitRepFunTys ty
 695     extra_arg_tys       = take excess_arity arg_tys
 696     final_res_ty        = mkFunTys (drop excess_arity arg_tys) res_ty
 697 \end{code}
 698
 699 \begin{code}
 700 -- Stg doesn't have a lambda *expression*
 701 deStgLam (StgLam ty bndrs body)
 702         -- Try for eta reduction
 703   = ASSERT( not (null bndrs) )
 704     case eta body of
 705         Just e  ->      -- Eta succeeded
 706                     returnUs e
 707
 708         Nothing ->      -- Eta failed, so let-bind the lambda
 709                     newStgVar ty                `thenUs` \ fn ->
 710                     returnUs (StgLet (StgNonRec fn lam_closure) (StgApp fn []))
 711   where
 712     lam_closure = StgRhsClosure noCCS
 713                                 stgArgOcc
 714                                 noSRT
 715                                 bOGUS_FVs
 716                                 ReEntrant       -- binders is non-empty
 717                                 bndrs
 718                                 body
 719
 720     eta (StgApp f args)
 721         | n_remaining >= 0 &&
 722           and (zipWith ok bndrs last_args) &&
 723           notInExpr bndrs remaining_expr
 724         = Just remaining_expr
 725         where
 726           remaining_expr = StgApp f remaining_args
 727           (remaining_args, last_args) = splitAt n_remaining args
 728           n_remaining = length args - length bndrs
 729
 730     eta (StgLet bind@(StgNonRec b r) body)
 731         | notInRhs bndrs r = case eta body of
 732                                 Just e -> Just (StgLet bind e)
 733                                 Nothing -> Nothing
 734
 735     eta _ = Nothing
 736
 737     ok bndr (StgVarArg arg) = bndr == arg
 738     ok bndr other           = False
 739
 740 deStgLam expr = returnUs expr
 741
 742
 743 --------------------------------------------------
 744 notInExpr :: [Id] -> StgExpr -> Bool
 745 notInExpr vs (StgApp f args)               = notInId vs f && notInArgs vs args
 746 notInExpr vs (StgLet (StgNonRec b r) body) = notInRhs vs r && notInExpr vs body
 747 notInExpr vs other                         = False      -- Safe
 748
 749 notInRhs :: [Id] -> StgRhs -> Bool
 750 notInRhs vs (StgRhsCon _ _ args)             = notInArgs vs args
 751 notInRhs vs (StgRhsClosure _ _ _ _ _ _ body) = notInExpr vs body
 752         -- Conservative: we could delete the binders from vs, but
 753         -- cloning means this will never help
 754
 755 notInArgs :: [Id] -> [StgArg] -> Bool
 756 notInArgs vs args = all ok args
 757                   where
 758                     ok (StgVarArg v) = notInId vs v
 759                     ok (StgLitArg l) = True
 760
 761 notInId :: [Id] -> Id -> Bool
 762 notInId vs v = not (v `elem` vs)
 763
 764
 765
 766 mkStgBinds :: [StgFloatBind]
 767            -> StgExpr           -- *Can* be a StgLam
 768            -> UniqSM StgExpr    -- *Can* be a StgLam
 769
 770 mkStgBinds []     body = returnUs body
 771 mkStgBinds (b:bs) body
 772   = deStgLam body               `thenUs` \ body' ->
 773     go (b:bs) body'
 774   where
 775     go []     body = returnUs body
 776     go (b:bs) body = go bs body         `thenUs` \ body' ->
 777                      mkStgBind  b body'
 778
 779 -- The 'body' arg of mkStgBind can't be a StgLam
 780 mkStgBind NoBindF    body = returnUs body
 781 mkStgBind (RecF prs) body = returnUs (StgLet (StgRec prs) body)
 782
 783 mkStgBind (NonRecF bndr rhs dem floats) body
 784 #ifdef DEBUG
 785         -- We shouldn't get let or case of the form v=w
 786   = case rhs of
 787         StgApp v [] -> pprTrace "mkStgLet" (ppr bndr <+> ppr v)
 788                        (mk_stg_let bndr rhs dem floats body)
 789         other       ->  mk_stg_let bndr rhs dem floats body
 790
 791 mk_stg_let bndr rhs dem floats body
 792 #endif
 793   | isUnLiftedType bndr_rep_ty                  -- Use a case/PrimAlts
 794   = ASSERT( not (isUnboxedTupleType bndr_rep_ty) )
 795     mkStgBinds floats $
 796     mkStgCase rhs bndr (StgPrimAlts bndr_rep_ty [] (StgBindDefault body))
 797
 798   | is_whnf
 799   = if is_strict then
 800         -- Strict let with WHNF rhs
 801         mkStgBinds floats $
 802         StgLet (StgNonRec bndr (exprToRhs dem NotTopLevel rhs)) body
 803     else
 804         -- Lazy let with WHNF rhs; float until we find a strict binding
 805         let
 806             (floats_out, floats_in) = splitFloats floats
 807         in
 808         mkStgBinds floats_in rhs        `thenUs` \ new_rhs ->
 809         mkStgBinds floats_out $
 810         StgLet (StgNonRec bndr (exprToRhs dem NotTopLevel new_rhs)) body
 811
 812   | otherwise   -- Not WHNF
 813   = if is_strict then
 814         -- Strict let with non-WHNF rhs
 815         mkStgBinds floats $
 816         mkStgCase rhs bndr (StgAlgAlts bndr_rep_ty [] (StgBindDefault body))
 817     else
 818         -- Lazy let with non-WHNF rhs, so keep the floats in the RHS
 819         mkStgBinds floats rhs           `thenUs` \ new_rhs ->
 820         returnUs (StgLet (StgNonRec bndr (exprToRhs dem NotTopLevel new_rhs)) body)
 821
 822   where
 823     bndr_rep_ty = repType (idType bndr)
 824     is_strict   = isStrictDem dem
 825     is_whnf     = case rhs of
 826                     StgConApp _ _ -> True
 827                     StgLam _ _ _  -> True
 828                     other         -> False
 829
 830 -- Split at the first strict binding
 831 splitFloats fs@(NonRecF _ _ dem _ : _)
 832   | isStrictDem dem = ([], fs)
 833
 834 splitFloats (f : fs) = case splitFloats fs of
 835                              (fs_out, fs_in) -> (f : fs_out, fs_in)
 836
 837 splitFloats [] = ([], [])
 838 \end{code}
 839
 840
 841 Making an STG case
 842 ~~~~~~~~~~~~~~~~~~
 843
 844 First, two special cases.  We mangle cases involving
 845                 par# and seq#
 846 inthe scrutinee.
 847
 848 Up to this point, seq# will appear like this:
 849
 850           case seq# e of
 851                 0# -> seqError#
 852                 _  -> <stuff>
 853
 854 This code comes from an unfolding for 'seq' in Prelude.hs.
 855 The 0# branch is purely to bamboozle the strictness analyser.
 856 For example, if <stuff> is strict in x, and there was no seqError#
 857 branch, the strictness analyser would conclude that the whole expression
 858 was strict in x, and perhaps evaluate x first -- but that would be a DISASTER.
 859
 860 Now that the evaluation order is safe, we translate this into
 861
 862           case e of
 863                 _ -> ...
 864
 865 This used to be done in the post-simplification phase, but we need
 866 unfoldings involving seq# to appear unmangled in the interface file,
 867 hence we do this mangling here.
 868
 869 Similarly, par# has an unfolding in PrelConc.lhs that makes it show
 870 up like this:
 871
 872         case par# e of
 873           0# -> rhs
 874           _  -> parError#
 875
 876
 877     ==>
 878         case par# e of
 879           _ -> rhs
 880
 881 fork# isn't handled like this - it's an explicit IO operation now.
 882 The reason is that fork# returns a ThreadId#, which gets in the
 883 way of the above scheme.  And anyway, IO is the only guaranteed
 884 way to enforce ordering  --SDM.
 885
 886
 887 \begin{code}
 888 -- Discard alernatives in case (par# ..) of
 889 mkStgCase scrut@(StgPrimApp ParOp _ _) bndr
 890           (StgPrimAlts ty _ deflt@(StgBindDefault _))
 891   = StgCase scrut bOGUS_LVs bOGUS_LVs bndr noSRT (StgPrimAlts ty [] deflt)
 892
 893 mkStgCase (StgPrimApp SeqOp [scrut] _) bndr
 894           (StgPrimAlts _ _ deflt@(StgBindDefault rhs))
 895   = mkStgCase scrut_expr new_bndr (StgAlgAlts scrut_ty [] (StgBindDefault rhs))
 896   where
 897     new_alts | isUnLiftedType scrut_ty = WARN( True, text "mkStgCase" ) StgPrimAlts scrut_ty [] deflt
 898              | otherwise               = StgAlgAlts  scrut_ty [] deflt
 899     scrut_ty = stgArgType scrut
 900     new_bndr = setIdType bndr scrut_ty
 901         -- NB:  SeqOp :: forall a. a -> Int#
 902         -- So bndr has type Int#
 903         -- But now we are going to scrutinise the SeqOp's argument directly,
 904         -- so we must change the type of the case binder to match that
 905         -- of the argument expression e.
 906
 907     scrut_expr = case scrut of
 908                    StgVarArg v -> StgApp v []
 909                    -- Others should not happen because
 910                    -- seq of a value should have disappeared
 911                    StgLitArg l -> WARN( True, text "seq on" <+> ppr l ) StgLit l
 912
 913 mkStgCase scrut bndr alts
 914   = ASSERT( case scrut of { StgLam _ _ _ -> False; other -> True } )
 915         -- We should never find
 916         --      case (\x->e) of { ... }
 917         -- The simplifier eliminates such things
 918     StgCase scrut bOGUS_LVs bOGUS_LVs bndr noSRT alts
 919 \end{code}