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