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