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