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