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