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(..), 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 || 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     returnUs (binds, mkStgCase scrut' bndr' alts')
 547   where
 548     scrut_ty  = idType bndr
 549     prim_case = isUnLiftedType scrut_ty && not (isUnboxedTupleType scrut_ty)
 550
 551     alts_to_stg env (alts, deflt)
 552       | prim_case
 553       = default_to_stg env deflt                `thenUs` \ deflt' ->
 554         mapUs (prim_alt_to_stg env) alts        `thenUs` \ alts' ->
 555         returnUs (mkStgPrimAlts scrut_ty alts' deflt')
 556
 557       | otherwise
 558       = default_to_stg env deflt                `thenUs` \ deflt' ->
 559         mapUs (alg_alt_to_stg env) alts         `thenUs` \ alts' ->
 560         returnUs (mkStgAlgAlts scrut_ty alts' deflt')
 561
 562     alg_alt_to_stg env (DataAlt con, bs, rhs)
 563           = newLocalIds NotTopLevel env (filter isId bs)        `thenUs` \ (env', stg_bs) ->
 564             coreExprToStg env' rhs                              `thenUs` \ stg_rhs ->
 565             returnUs (con, stg_bs, [ True | b <- stg_bs ]{-bogus use mask-}, stg_rhs)
 566                 -- NB the filter isId.  Some of the binders may be
 567                 -- existential type variables, which STG doesn't care about
 568
 569     prim_alt_to_stg env (LitAlt lit, args, rhs)
 570           = ASSERT( null args )
 571             coreExprToStg env rhs       `thenUs` \ stg_rhs ->
 572             returnUs (lit, stg_rhs)
 573
 574     default_to_stg env Nothing
 575       = returnUs StgNoDefault
 576
 577     default_to_stg env (Just rhs)
 578       = coreExprToStg env rhs   `thenUs` \ stg_rhs ->
 579         returnUs (StgBindDefault stg_rhs)
 580                 -- The binder is used for prim cases and not otherwise
 581                 -- (hack for old code gen)
 582 \end{code}
 583
 584
 585 %************************************************************************
 586 %*                                                                      *
 587 \subsection[coreToStg-misc]{Miscellaneous helping functions}
 588 %*                                                                      *
 589 %************************************************************************
 590
 591 There's not anything interesting we can ASSERT about \tr{var} if it
 592 isn't in the StgEnv. (WDP 94/06)
 593
 594 Invent a fresh @Id@:
 595 \begin{code}
 596 newStgVar :: Type -> UniqSM Id
 597 newStgVar ty
 598  = getUniqueUs                  `thenUs` \ uniq ->
 599    seqType ty                   `seq`
 600    returnUs (mkSysLocal SLIT("stg") uniq ty)
 601 \end{code}
 602
 603 \begin{code}
 604 newLocalId TopLevel env id
 605   -- Don't clone top-level binders.  MkIface relies on their
 606   -- uniques staying the same, so it can snaffle IdInfo off the
 607   -- STG ids to put in interface files.
 608   = let
 609       name = idName id
 610       ty   = idType id
 611     in
 612     name                `seq`
 613     seqType ty          `seq`
 614     returnUs (env, mkVanillaId name ty)
 615
 616
 617 newLocalId NotTopLevel env id
 618   =     -- Local binder, give it a new unique Id.
 619     getUniqueUs                 `thenUs` \ uniq ->
 620     let
 621       name    = idName id
 622       ty      = idType id
 623       new_id  = mkVanillaId (setNameUnique name uniq) ty
 624       new_env = extendVarEnv env id new_id
 625     in
 626     name                `seq`
 627     seqType ty          `seq`
 628     returnUs (new_env, new_id)
 629
 630 newLocalIds :: TopLevelFlag -> StgEnv -> [Id] -> UniqSM (StgEnv, [Id])
 631 newLocalIds top_lev env []
 632   = returnUs (env, [])
 633 newLocalIds top_lev env (b:bs)
 634   = newLocalId top_lev env b    `thenUs` \ (env', b') ->
 635     newLocalIds top_lev env' bs `thenUs` \ (env'', bs') ->
 636     returnUs (env'', b':bs')
 637 \end{code}
 638
 639
 640 %************************************************************************
 641 %*                                                                      *
 642 \subsection{Building STG syn}
 643 %*                                                                      *
 644 %************************************************************************
 645
 646 \begin{code}
 647 mkStgAlgAlts  ty alts deflt = seqType ty `seq` StgAlgAlts  ty alts deflt
 648 mkStgPrimAlts ty alts deflt = seqType ty `seq` StgPrimAlts ty alts deflt
 649 mkStgLam ty bndrs body      = seqType ty `seq` StgLam ty bndrs body
 650
 651 mkStgApp :: StgEnv -> Id -> [StgArg] -> Type -> UniqSM StgExpr
 652         -- The type is the type of the entire application
 653 mkStgApp env fn args ty
 654  = case idFlavour fn_alias of
 655       DataConId dc
 656         -> saturate fn_alias args ty    $ \ args' ty' ->
 657            returnUs (StgConApp dc args')
 658
 659       PrimOpId (CCallOp (CCall (DynamicTarget _) a b c))
 660                 -- Sigh...make a guaranteed unique name for a dynamic ccall
 661         -> saturate fn_alias args ty    $ \ args' ty' ->
 662            getUniqueUs                  `thenUs` \ u ->
 663            returnUs (StgPrimApp (CCallOp (CCall (DynamicTarget u) a b c)) args' ty')
 664
 665       PrimOpId op
 666         -> saturate fn_alias args ty    $ \ args' ty' ->
 667            returnUs (StgPrimApp op args' ty')
 668
 669       other -> returnUs (StgApp fn_alias args)
 670                         -- Force the lookup
 671   where
 672     fn_alias = case (lookupVarEnv env fn) of    -- In case it's been cloned
 673                       Nothing  -> fn
 674                       Just fn' -> fn'
 675
 676 saturate :: Id -> [StgArg] -> Type -> ([StgArg] -> Type -> UniqSM StgExpr) -> UniqSM StgExpr
 677         -- The type should be the type of (id args)
 678 saturate fn args ty thing_inside
 679   | excess_arity == 0   -- Saturated, so nothing to do
 680   = thing_inside args ty
 681
 682   | otherwise   -- An unsaturated constructor or primop; eta expand it
 683   = ASSERT2( excess_arity > 0 && excess_arity <= length arg_tys,
 684              ppr fn <+> ppr args <+> ppr excess_arity <+> parens (ppr ty) <+> ppr arg_tys )
 685     mapUs newStgVar extra_arg_tys                               `thenUs` \ arg_vars ->
 686     thing_inside (args ++ map StgVarArg arg_vars) final_res_ty  `thenUs` \ body ->
 687     returnUs (StgLam ty arg_vars body)
 688   where
 689     fn_arity            = idArity fn
 690     excess_arity        = fn_arity - length args
 691     (arg_tys, res_ty)   = splitRepFunTys ty
 692     extra_arg_tys       = take excess_arity arg_tys
 693     final_res_ty        = mkFunTys (drop excess_arity arg_tys) res_ty
 694 \end{code}
 695
 696 \begin{code}
 697 -- Stg doesn't have a lambda *expression*
 698 deStgLam (StgLam ty bndrs body)
 699         -- Try for eta reduction
 700   = ASSERT( not (null bndrs) )
 701     case eta body of
 702         Just e  ->      -- Eta succeeded
 703                     returnUs e
 704
 705         Nothing ->      -- Eta failed, so let-bind the lambda
 706                     newStgVar ty                `thenUs` \ fn ->
 707                     returnUs (StgLet (StgNonRec fn lam_closure) (StgApp fn []))
 708   where
 709     lam_closure = StgRhsClosure noCCS
 710                                 stgArgOcc
 711                                 noSRT
 712                                 bOGUS_FVs
 713                                 ReEntrant       -- binders is non-empty
 714                                 bndrs
 715                                 body
 716
 717     eta (StgApp f args)
 718         | n_remaining >= 0 &&
 719           and (zipWith ok bndrs last_args) &&
 720           notInExpr bndrs remaining_expr
 721         = Just remaining_expr
 722         where
 723           remaining_expr = StgApp f remaining_args
 724           (remaining_args, last_args) = splitAt n_remaining args
 725           n_remaining = length args - length bndrs
 726
 727     eta (StgLet bind@(StgNonRec b r) body)
 728         | notInRhs bndrs r = case eta body of
 729                                 Just e -> Just (StgLet bind e)
 730                                 Nothing -> Nothing
 731
 732     eta _ = Nothing
 733
 734     ok bndr (StgVarArg arg) = bndr == arg
 735     ok bndr other           = False
 736
 737 deStgLam expr = returnUs expr
 738
 739
 740 --------------------------------------------------
 741 notInExpr :: [Id] -> StgExpr -> Bool
 742 notInExpr vs (StgApp f args)               = notInId vs f && notInArgs vs args
 743 notInExpr vs (StgLet (StgNonRec b r) body) = notInRhs vs r && notInExpr vs body
 744 notInExpr vs other                         = False      -- Safe
 745
 746 notInRhs :: [Id] -> StgRhs -> Bool
 747 notInRhs vs (StgRhsCon _ _ args)             = notInArgs vs args
 748 notInRhs vs (StgRhsClosure _ _ _ _ _ _ body) = notInExpr vs body
 749         -- Conservative: we could delete the binders from vs, but
 750         -- cloning means this will never help
 751
 752 notInArgs :: [Id] -> [StgArg] -> Bool
 753 notInArgs vs args = all ok args
 754                   where
 755                     ok (StgVarArg v) = notInId vs v
 756                     ok (StgLitArg l) = True
 757
 758 notInId :: [Id] -> Id -> Bool
 759 notInId vs v = not (v `elem` vs)
 760
 761
 762
 763 mkStgBinds :: [StgFloatBind]
 764            -> StgExpr           -- *Can* be a StgLam
 765            -> UniqSM StgExpr    -- *Can* be a StgLam
 766
 767 mkStgBinds []     body = returnUs body
 768 mkStgBinds (b:bs) body
 769   = deStgLam body               `thenUs` \ body' ->
 770     go (b:bs) body'
 771   where
 772     go []     body = returnUs body
 773     go (b:bs) body = go bs body         `thenUs` \ body' ->
 774                      mkStgBind  b body'
 775
 776 -- The 'body' arg of mkStgBind can't be a StgLam
 777 mkStgBind NoBindF    body = returnUs body
 778 mkStgBind (RecF prs) body = returnUs (StgLet (StgRec prs) body)
 779
 780 mkStgBind (NonRecF bndr rhs dem floats) body
 781 #ifdef DEBUG
 782         -- We shouldn't get let or case of the form v=w
 783   = case rhs of
 784         StgApp v [] -> pprTrace "mkStgLet" (ppr bndr <+> ppr v)
 785                        (mk_stg_let bndr rhs dem floats body)
 786         other       ->  mk_stg_let bndr rhs dem floats body
 787
 788 mk_stg_let bndr rhs dem floats body
 789 #endif
 790   | isUnLiftedType bndr_rep_ty                  -- Use a case/PrimAlts
 791   = ASSERT( not (isUnboxedTupleType bndr_rep_ty) )
 792     mkStgBinds floats $
 793     mkStgCase rhs bndr (StgPrimAlts bndr_rep_ty [] (StgBindDefault body))
 794
 795   | is_whnf
 796   = if is_strict then
 797         -- Strict let with WHNF rhs
 798         mkStgBinds floats $
 799         StgLet (StgNonRec bndr (exprToRhs dem NotTopLevel rhs)) body
 800     else
 801         -- Lazy let with WHNF rhs; float until we find a strict binding
 802         let
 803             (floats_out, floats_in) = splitFloats floats
 804         in
 805         mkStgBinds floats_in rhs        `thenUs` \ new_rhs ->
 806         mkStgBinds floats_out $
 807         StgLet (StgNonRec bndr (exprToRhs dem NotTopLevel new_rhs)) body
 808
 809   | otherwise   -- Not WHNF
 810   = if is_strict then
 811         -- Strict let with non-WHNF rhs
 812         mkStgBinds floats $
 813         mkStgCase rhs bndr (StgAlgAlts bndr_rep_ty [] (StgBindDefault body))
 814     else
 815         -- Lazy let with non-WHNF rhs, so keep the floats in the RHS
 816         mkStgBinds floats rhs           `thenUs` \ new_rhs ->
 817         returnUs (StgLet (StgNonRec bndr (exprToRhs dem NotTopLevel new_rhs)) body)
 818
 819   where
 820     bndr_rep_ty = repType (idType bndr)
 821     is_strict   = isStrictDem dem
 822     is_whnf     = case rhs of
 823                     StgConApp _ _ -> True
 824                     StgLam _ _ _  -> True
 825                     other         -> False
 826
 827 -- Split at the first strict binding
 828 splitFloats fs@(NonRecF _ _ dem _ : _)
 829   | isStrictDem dem = ([], fs)
 830
 831 splitFloats (f : fs) = case splitFloats fs of
 832                              (fs_out, fs_in) -> (f : fs_out, fs_in)
 833
 834 splitFloats [] = ([], [])
 835 \end{code}
 836
 837
 838 Making an STG case
 839 ~~~~~~~~~~~~~~~~~~
 840
 841 First, two special cases.  We mangle cases involving
 842                 par# and seq#
 843 inthe scrutinee.
 844
 845 Up to this point, seq# will appear like this:
 846
 847           case seq# e of
 848                 0# -> seqError#
 849                 _  -> <stuff>
 850
 851 This code comes from an unfolding for 'seq' in Prelude.hs.
 852 The 0# branch is purely to bamboozle the strictness analyser.
 853 For example, if <stuff> is strict in x, and there was no seqError#
 854 branch, the strictness analyser would conclude that the whole expression
 855 was strict in x, and perhaps evaluate x first -- but that would be a DISASTER.
 856
 857 Now that the evaluation order is safe, we translate this into
 858
 859           case e of
 860                 _ -> ...
 861
 862 This used to be done in the post-simplification phase, but we need
 863 unfoldings involving seq# to appear unmangled in the interface file,
 864 hence we do this mangling here.
 865
 866 Similarly, par# has an unfolding in PrelConc.lhs that makes it show
 867 up like this:
 868
 869         case par# e of
 870           0# -> rhs
 871           _  -> parError#
 872
 873
 874     ==>
 875         case par# e of
 876           _ -> rhs
 877
 878 fork# isn't handled like this - it's an explicit IO operation now.
 879 The reason is that fork# returns a ThreadId#, which gets in the
 880 way of the above scheme.  And anyway, IO is the only guaranteed
 881 way to enforce ordering  --SDM.
 882
 883
 884 \begin{code}
 885 -- Discard alernatives in case (par# ..) of
 886 mkStgCase scrut@(StgPrimApp ParOp _ _) bndr
 887           (StgPrimAlts ty _ deflt@(StgBindDefault _))
 888   = StgCase scrut bOGUS_LVs bOGUS_LVs bndr noSRT (StgPrimAlts ty [] deflt)
 889
 890 mkStgCase (StgPrimApp SeqOp [scrut] _) bndr
 891           (StgPrimAlts _ _ deflt@(StgBindDefault rhs))
 892   = mkStgCase scrut_expr new_bndr (StgAlgAlts scrut_ty [] (StgBindDefault rhs))
 893   where
 894     new_alts | isUnLiftedType scrut_ty = WARN( True, text "mkStgCase" ) StgPrimAlts scrut_ty [] deflt
 895              | otherwise               = StgAlgAlts  scrut_ty [] deflt
 896     scrut_ty = stgArgType scrut
 897     new_bndr = setIdType bndr scrut_ty
 898         -- NB:  SeqOp :: forall a. a -> Int#
 899         -- So bndr has type Int#
 900         -- But now we are going to scrutinise the SeqOp's argument directly,
 901         -- so we must change the type of the case binder to match that
 902         -- of the argument expression e.
 903
 904     scrut_expr = case scrut of
 905                    StgVarArg v -> StgApp v []
 906                    -- Others should not happen because
 907                    -- seq of a value should have disappeared
 908                    StgLitArg l -> WARN( True, text "seq on" <+> ppr l ) StgLit l
 909
 910 mkStgCase scrut bndr alts
 911   = ASSERT( case scrut of { StgLam _ _ _ -> False; other -> True } )
 912         -- We should never find
 913         --      case (\x->e) of { ... }
 914         -- The simplifier eliminates such things
 915     StgCase scrut bOGUS_LVs bOGUS_LVs bndr noSRT alts
 916 \end{code}