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