X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FstgSyn%2FCoreToStg.lhs;h=fc0a8d52c704c8845118f39fde5c9c2bf79b9ad5;hb=91ef36b9f74a61c0fb0047f3261ce49ed3026e93;hp=c3bd393c518026a860b8ecd6e09a9ccbb1245dc0;hpb=7b0181919416d8f04324575b7e17031ca692f5b0;p=ghc-hetmet.git diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs index c3bd393..fc0a8d5 100644 --- a/ghc/compiler/stgSyn/CoreToStg.lhs +++ b/ghc/compiler/stgSyn/CoreToStg.lhs @@ -1,5 +1,5 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % %************************************************************************ %* * @@ -9,63 +9,92 @@ Convert a @CoreSyntax@ program to a @StgSyntax@ program. - \begin{code} -#include "HsVersions.h" - module CoreToStg ( topCoreBindsToStg ) where -import Ubiq{-uitous-} +#include "HsVersions.h" import CoreSyn -- input import StgSyn -- output -import Bag ( emptyBag, unitBag, unionBags, unionManyBags, bagToList ) -import CoreUtils ( coreExprType ) -import CostCentre ( noCostCentre ) -import Id ( mkSysLocal, idType, isBottomingId, - nullIdEnv, addOneToIdEnv, lookupIdEnv, - IdEnv(..), GenId{-instance NamedThing-} +import PprCore ( {- instance Outputable Bind/Expr -} ) +import CoreUtils ( exprType ) +import SimplUtils ( findDefault ) +import CostCentre ( noCCS ) +import Id ( Id, mkSysLocal, idType, idStrictness, idUnique, isExportedId, mkVanillaId, + externallyVisibleId, setIdUnique, idName, + idDemandInfo, idArity, setIdType, idFlavour ) -import Literal ( mkMachInt, Literal(..) ) -import Name ( isExported ) -import PrelInfo ( unpackCStringId, unpackCString2Id, stringTy, - integerTy, rationalTy, ratioDataCon, - integerZeroId, integerPlusOneId, - integerPlusTwoId, integerMinusOneId +import Var ( Var, varType, modifyIdInfo ) +import IdInfo ( setDemandInfo, StrictnessInfo(..), IdFlavour(..) ) +import UsageSPUtils ( primOpUsgTys ) +import DataCon ( DataCon, dataConName, dataConWrapId ) +import Demand ( Demand, isStrict, wwStrict, wwLazy ) +import Name ( Name, nameModule, isLocallyDefinedName, setNameUnique ) +import Literal ( Literal(..) ) +import VarEnv +import PrimOp ( PrimOp(..), CCall(..), CCallTarget(..), primOpUsg ) +import Type ( isUnLiftedType, isUnboxedTupleType, Type, splitFunTy_maybe, + UsageAnn(..), tyUsg, applyTy, mkUsgTy, repType, seqType, + splitRepFunTys, mkFunTys ) -import PrimOp ( PrimOp(..) ) -import SpecUtils ( mkSpecialisedCon ) -import SrcLoc ( mkUnknownSrcLoc ) -import Type ( getAppDataTyCon ) +import TysPrim ( intPrimTy ) import UniqSupply -- all of it, really -import Util ( panic ) - -isLeakFreeType = panic "CoreToStg.isLeakFreeType (ToDo)" +import Util ( lengthExceeds ) +import BasicTypes ( TopLevelFlag(..), isNotTopLevel, Arity ) +import CmdLineOpts ( opt_D_verbose_stg2stg, opt_UsageSPOn ) +import UniqSet ( emptyUniqSet ) +import Maybes +import Outputable \end{code} + ************************************************* *************** OVERVIEW ********************* + ************************************************* -The business of this pass is to convert Core to Stg. On the way: +The business of this pass is to convert Core to Stg. On the way it +does some important transformations: -* We discard type lambdas and applications. In so doing we discard - "trivial" bindings such as +1. We discard type lambdas and applications. In so doing we discard + "trivial" bindings such as x = y t1 t2 - where t1, t2 are types + where t1, t2 are types + +2. We get the program into "A-normal form". In particular: + + f E ==> let x = E in f x + OR ==> case E of x -> f x + + where E is a non-trivial expression. + Which transformation is used depends on whether f is strict or not. + [Previously the transformation to case used to be done by the + simplifier, but it's better done here. It does mean that f needs + to have its strictness info correct!.] + + Similarly, convert any unboxed let's into cases. + [I'm experimenting with leaving 'ok-for-speculation' rhss in let-form + right up to this point.] -* We make the representation of NoRep literals explicit, and - float their bindings to the top level +3. We clone all local binders. The code generator uses the uniques to + name chunks of code for thunks, so it's important that the names used + are globally unique, not simply not-in-scope, which is all that + the simplifier ensures. + + +NOTE THAT: + +* We don't pin on correct arities any more, because they can be mucked up + by the lambda lifter. In particular, the lambda lifter can take a local + letrec-bound variable and make it a lambda argument, which shouldn't have + an arity. So SetStgVarInfo sets arities now. * We do *not* pin on the correct free/live var info; that's done later. Instead we use bOGUS_LVS and _FVS as a placeholder. -* We convert case x of {...; x' -> ...x'...} - to - case x of {...; _ -> ...x... } - - See notes in SimplCase.lhs, near simplDefault for the reasoning here. +[Quite a bit of stuff that used to be here has moved + to tidyCorePgm (SimplCore.lhs) SLPJ Nov 96] %************************************************************************ @@ -74,104 +103,117 @@ The business of this pass is to convert Core to Stg. On the way: %* * %************************************************************************ -Because we're going to come across ``boring'' bindings like -\tr{let x = /\ tyvars -> y in ...}, we want to keep a small -environment, so we can just replace all occurrences of \tr{x} -with \tr{y}. +March 98: We keep a small environment to give all locally bound +Names new unique ids, since the code generator assumes that binders +are unique across a module. (Simplifier doesn't maintain this +invariant any longer.) + +A binder to be floated out becomes an @StgFloatBind@. \begin{code} -type StgEnv = IdEnv StgArg +type StgEnv = IdEnv Id + +data StgFloatBind = NoBindF + | RecF [(Id, StgRhs)] + | NonRecF + Id + StgExpr -- *Can* be a StgLam + RhsDemand + [StgFloatBind] + +-- The interesting one is the NonRecF +-- NonRecF x rhs demand binds +-- means +-- x = let binds in rhs +-- (or possibly case etc if x demand is strict) +-- The binds are kept separate so they can be floated futher +-- if appropriate +\end{code} + +A @RhsDemand@ gives the demand on an RHS: strict (@isStrictDem@) and +thus case-bound, or if let-bound, at most once (@isOnceDem@) or +otherwise. + +\begin{code} +data RhsDemand = RhsDemand { isStrictDem :: Bool, -- True => used at least once + isOnceDem :: Bool -- True => used at most once + } + +mkDem :: Demand -> Bool -> RhsDemand +mkDem strict once = RhsDemand (isStrict strict) once + +mkDemTy :: Demand -> Type -> RhsDemand +mkDemTy strict ty = RhsDemand (isStrict strict) (isOnceTy ty) + +isOnceTy :: Type -> Bool +isOnceTy ty + = +#ifdef USMANY + opt_UsageSPOn && -- can't expect annotations if -fusagesp is off +#endif + case tyUsg ty of + UsOnce -> True + UsMany -> False + UsVar uv -> pprPanic "CoreToStg: unexpected uvar annot:" (ppr uv) + +bdrDem :: Id -> RhsDemand +bdrDem id = mkDem (idDemandInfo id) (isOnceTy (idType id)) + +safeDem, onceDem :: RhsDemand +safeDem = RhsDemand False False -- always safe to use this +onceDem = RhsDemand False True -- used at most once \end{code} No free/live variable information is pinned on in this pass; it's added later. For this pass we use @bOGUS_LVs@ and @bOGUS_FVs@ as placeholders. +When printing out the Stg we need non-bottom values in these +locations. + \begin{code} bOGUS_LVs :: StgLiveVars -bOGUS_LVs = panic "bOGUS_LVs" -- emptyUniqSet (used when pprTracing) +bOGUS_LVs | opt_D_verbose_stg2stg = emptyUniqSet + | otherwise =panic "bOGUS_LVs" bOGUS_FVs :: [Id] -bOGUS_FVs = panic "bOGUS_FVs" -- [] (ditto) +bOGUS_FVs | opt_D_verbose_stg2stg = [] + | otherwise = panic "bOGUS_FVs" \end{code} \begin{code} topCoreBindsToStg :: UniqSupply -- name supply - -> [CoreBinding] -- input + -> [CoreBind] -- input -> [StgBinding] -- output topCoreBindsToStg us core_binds - = case (initUs us (binds_to_stg nullIdEnv core_binds)) of - (_, stuff) -> stuff + = initUs_ us (coreBindsToStg emptyVarEnv core_binds) where - binds_to_stg :: StgEnv -> [CoreBinding] -> UniqSM [StgBinding] - - binds_to_stg env [] = returnUs [] - binds_to_stg env (b:bs) - = do_top_bind env b `thenUs` \ (new_b, new_env, float_binds) -> - binds_to_stg new_env bs `thenUs` \ new_bs -> - returnUs (bagToList float_binds ++ -- Literals - new_b ++ - new_bs) - - do_top_bind env bind@(Rec pairs) - = coreBindToStg env bind - - do_top_bind env bind@(NonRec var rhs) - = coreBindToStg env bind `thenUs` \ (stg_binds, new_env, float_binds) -> -{- TESTING: - let - ppr_blah xs = ppInterleave ppComma (map pp_x xs) - pp_x (u,x) = ppBesides [pprUnique u, ppStr ": ", ppr PprDebug x] - in - pprTrace "do_top_bind:" (ppAbove (ppr PprDebug stg_binds) (ppr_blah (ufmToList new_env))) $ --} - case stg_binds of - [StgNonRec var (StgRhsClosure cc bi fvs u [] rhs_body)] -> - -- Mega-special case; there's still a binding there - -- no fvs (of course), *no args*, "let" rhs - let - (extra_float_binds, rhs_body') = seek_liftable [] rhs_body - in - returnUs (extra_float_binds ++ - [StgNonRec var (StgRhsClosure cc bi fvs u [] rhs_body')], - new_env, - float_binds) - - other -> returnUs (stg_binds, new_env, float_binds) - - -------------------- - -- HACK: look for very simple, obviously-liftable bindings - -- that can come up to the top level; those that couldn't - -- 'cause they were big-lambda constrained in the Core world. - - seek_liftable :: [StgBinding] -- accumulator... - -> StgExpr -- look for top-lev liftables - -> ([StgBinding], StgExpr) -- result - - seek_liftable acc expr@(StgLet inner_bind body) - | is_liftable inner_bind - = seek_liftable (inner_bind : acc) body - - seek_liftable acc other_expr = (reverse acc, other_expr) -- Finished - - -------------------- - is_liftable (StgNonRec binder (StgRhsClosure _ _ _ _ args body)) - = not (null args) -- it's manifestly a function... - || isLeakFreeType [] (idType binder) - || is_whnf body - -- ToDo: use a decent manifestlyWHNF function for STG? - where - is_whnf (StgCon _ _ _) = True - is_whnf (StgApp (StgVarArg v) _ _) = isBottomingId v - is_whnf other = False - - is_liftable (StgRec [(_, StgRhsClosure _ _ _ _ args body)]) - = not (null args) -- it's manifestly a (recursive) function... - - is_liftable anything_else = False + coreBindsToStg :: StgEnv -> [CoreBind] -> UniqSM [StgBinding] + + coreBindsToStg env [] = returnUs [] + coreBindsToStg env (b:bs) + = coreBindToStg TopLevel env b `thenUs` \ (bind_spec, new_env) -> + coreBindsToStg new_env bs `thenUs` \ new_bs -> + case bind_spec of + NonRecF bndr rhs dem floats + -> ASSERT2( not (isStrictDem dem) && + not (isUnLiftedType (idType bndr)), + ppr b ) -- No top-level cases! + + mkStgBinds floats rhs `thenUs` \ new_rhs -> + returnUs (StgNonRec bndr (exprToRhs dem TopLevel new_rhs) + : new_bs) + -- Keep all the floats inside... + -- Some might be cases etc + -- We might want to revisit this decision + + RecF prs -> returnUs (StgRec prs : new_bs) + NoBindF -> pprTrace "topCoreBindsToStg" (ppr b) $ + returnUs new_bs \end{code} + %************************************************************************ %* * \subsection[coreToStg-binds]{Converting bindings} @@ -179,46 +221,35 @@ topCoreBindsToStg us core_binds %************************************************************************ \begin{code} -coreBindToStg :: StgEnv - -> CoreBinding - -> UniqSM ([StgBinding], -- Empty or singleton - StgEnv, -- New envt - Bag StgBinding) -- Floats +coreBindToStg :: TopLevelFlag -> StgEnv -> CoreBind -> UniqSM (StgFloatBind, StgEnv) + +coreBindToStg top_lev env (NonRec binder rhs) + = coreExprToStgFloat env rhs `thenUs` \ (floats, stg_rhs) -> + case (floats, stg_rhs) of + ([], StgApp var []) | not (isExportedId binder) + -> returnUs (NoBindF, extendVarEnv env binder var) + -- A trivial binding let x = y in ... + -- can arise if postSimplExpr floats a NoRep literal out + -- so it seems sensible to deal with it well. + -- But we don't want to discard exported things. They can + -- occur; e.g. an exported user binding f = g + + other -> newLocalId top_lev env binder `thenUs` \ (new_env, new_binder) -> + returnUs (NonRecF new_binder stg_rhs dem floats, new_env) + where + dem = bdrDem binder -coreBindToStg env (NonRec binder rhs) - = coreRhsToStg env rhs `thenUs` \ (stg_rhs, rhs_binds) -> - let - -- Binds to return if RHS is trivial - triv_binds = if isExported binder then - [StgNonRec binder stg_rhs] -- Retain it - else - [] -- Discard it - in - case stg_rhs of - StgRhsClosure cc bi fvs upd [] (StgApp atom [] lvs) -> - -- Trivial RHS, so augment envt, and ditch the binding - returnUs (triv_binds, new_env, rhs_binds) - where - new_env = addOneToIdEnv env binder atom - - StgRhsCon cc con_id [] -> - -- Trivial RHS, so augment envt, and ditch the binding - returnUs (triv_binds, new_env, rhs_binds) - where - new_env = addOneToIdEnv env binder (StgVarArg con_id) - - other -> -- Non-trivial RHS, so don't augment envt - returnUs ([StgNonRec binder stg_rhs], env, rhs_binds) - -coreBindToStg env (Rec pairs) - = -- NB: *** WE DO NOT CHECK FOR TRIV_BINDS in REC BIND **** - -- (possibly ToDo) - let - (binders, rhss) = unzip pairs - in - mapAndUnzipUs (coreRhsToStg env) rhss `thenUs` \ (stg_rhss, rhs_binds) -> - returnUs ([StgRec (binders `zip` stg_rhss)], env, unionManyBags rhs_binds) +coreBindToStg top_lev env (Rec pairs) + = newLocalIds top_lev env binders `thenUs` \ (env', binders') -> + mapUs (do_rhs env') pairs `thenUs` \ stg_rhss -> + returnUs (RecF (binders' `zip` stg_rhss), env') + where + binders = map fst pairs + do_rhs env (bndr,rhs) = coreExprToStgFloat env rhs `thenUs` \ (floats, stg_expr) -> + mkStgBinds floats stg_expr `thenUs` \ stg_expr' -> + -- NB: stg_expr' might still be a StgLam (and we want that) + returnUs (exprToRhs (bdrDem bndr) top_lev stg_expr') \end{code} @@ -229,192 +260,166 @@ coreBindToStg env (Rec pairs) %************************************************************************ \begin{code} -coreRhsToStg :: StgEnv -> CoreExpr -> UniqSM (StgRhs, Bag StgBinding) - -coreRhsToStg env core_rhs - = coreExprToStg env core_rhs `thenUs` \ (stg_expr, stg_binds) -> - - let stg_rhs = case stg_expr of - StgLet (StgNonRec var1 rhs) (StgApp (StgVarArg var2) [] _) - | var1 == var2 -> rhs - -- This curious stuff is to unravel what a lambda turns into - -- We have to do it this way, rather than spot a lambda in the - -- incoming rhs - - StgCon con args _ -> StgRhsCon noCostCentre con args - - other -> StgRhsClosure noCostCentre -- No cost centre (ToDo?) - stgArgOcc -- safe - bOGUS_FVs - Updatable -- Be pessimistic - [] - stg_expr - in - returnUs (stg_rhs, stg_binds) +exprToRhs :: RhsDemand -> TopLevelFlag -> StgExpr -> StgRhs +exprToRhs dem _ (StgLam _ bndrs body) + = ASSERT( not (null bndrs) ) + StgRhsClosure noCCS + stgArgOcc + noSRT + bOGUS_FVs + ReEntrant -- binders is non-empty + bndrs + body + +{- + We reject the following candidates for 'static constructor'dom: + + - any dcon that takes a lit-lit as an arg. + - [Win32 DLLs only]: any dcon that resides in a DLL + (or takes as arg something that is.) + + These constraints are necessary to ensure that the code + generated in the end for the static constructors, which + live in the data segment, remain valid - i.e., it has to + be constant. For obvious reasons, that's hard to guarantee + with lit-lits. The second case of a constructor referring + to static closures hiding out in some DLL is an artifact + of the way Win32 DLLs handle global DLL variables. A (data) + symbol exported from a DLL has to be accessed through a + level of indirection at the site of use, so whereas + + extern StgClosure y_closure; + extern StgClosure z_closure; + x = { ..., &y_closure, &z_closure }; + + is legal when the symbols are in scope at link-time, it is + not when y_closure is in a DLL. So, any potential static + closures that refers to stuff that's residing in a DLL + will be put in an (updateable) thunk instead. + + An alternative strategy is to support the generation of + constructors (ala C++ static class constructors) which will + then be run at load time to fix up static closures. +-} +exprToRhs dem toplev (StgConApp con args) + | isNotTopLevel toplev || not (isDllConApp con args) + -- isDllConApp checks for LitLit args too + = StgRhsCon noCCS con args + +exprToRhs dem _ expr + = upd `seq` + StgRhsClosure noCCS -- No cost centre (ToDo?) + stgArgOcc -- safe + noSRT -- figure out later + bOGUS_FVs + upd + [] + expr + where + upd = if isOnceDem dem then SingleEntry else Updatable + -- HA! Paydirt for "dem" \end{code} %************************************************************************ %* * -\subsection[coreToStg-lits]{Converting literals} +\subsection[coreToStg-atoms{Converting atoms} %* * %************************************************************************ -Literals: the NoRep kind need to be de-no-rep'd. -We always replace them with a simple variable, and float a suitable -binding out to the top level. +\begin{code} +coreArgsToStg :: StgEnv -> [(CoreArg,RhsDemand)] -> UniqSM ([StgFloatBind], [StgArg]) +-- Arguments are all value arguments (tyargs already removed), paired with their demand -If an Integer is small enough (Haskell implementations must support -Ints in the range $[-2^29+1, 2^29-1]$), wrap it up in @int2Integer@; -otherwise, wrap with @litString2Integer@. +coreArgsToStg env [] + = returnUs ([], []) -\begin{code} -tARGET_MIN_INT, tARGET_MAX_INT :: Integer -tARGET_MIN_INT = -536870912 -tARGET_MAX_INT = 536870912 +coreArgsToStg env (ad:ads) + = coreArgToStg env ad `thenUs` \ (bs1, a') -> + coreArgsToStg env ads `thenUs` \ (bs2, as') -> + returnUs (bs1 ++ bs2, a' : as') -litToStgArg :: Literal -> UniqSM (StgArg, Bag StgBinding) -litToStgArg (NoRepStr s) - = newStgVar stringTy `thenUs` \ var -> - let - rhs = StgRhsClosure noCostCentre -- No cost centre (ToDo?) - stgArgOcc -- safe - bOGUS_FVs - Updatable -- WAS: ReEntrant (see note below) - [] -- No arguments - val - --- We used not to update strings, so that they wouldn't clog up the heap, --- but instead be unpacked each time. But on some programs that costs a lot --- [eg hpg], so now we update them. - - val = if (any is_NUL (_UNPK_ s)) then -- must cater for NULs in literal string - StgApp (StgVarArg unpackCString2Id) - [StgLitArg (MachStr s), - StgLitArg (mkMachInt (toInteger (_LENGTH_ s)))] - bOGUS_LVs - else - StgApp (StgVarArg unpackCStringId) - [StgLitArg (MachStr s)] - bOGUS_LVs - in - returnUs (StgVarArg var, unitBag (StgNonRec var rhs)) +coreArgToStg :: StgEnv -> (CoreArg,RhsDemand) -> UniqSM ([StgFloatBind], StgArg) +-- This is where we arrange that a non-trivial argument is let-bound + +coreArgToStg env (arg,dem) + = coreExprToStgFloat env arg `thenUs` \ (floats, arg') -> + case arg' of + StgApp v [] -> returnUs (floats, StgVarArg v) + StgLit lit -> returnUs (floats, StgLitArg lit) + + StgConApp con [] -> returnUs (floats, StgVarArg (dataConWrapId con)) + -- A nullary constructor can be replaced with + -- a ``call'' to its wrapper + + other -> newStgVar arg_ty `thenUs` \ v -> + returnUs ([NonRecF v arg' dem floats], StgVarArg v) where - is_NUL c = c == '\0' - -litToStgArg (NoRepInteger i) - -- extremely convenient to look out for a few very common - -- Integer literals! - | i == 0 = returnUs (StgVarArg integerZeroId, emptyBag) - | i == 1 = returnUs (StgVarArg integerPlusOneId, emptyBag) - | i == 2 = returnUs (StgVarArg integerPlusTwoId, emptyBag) - | i == (-1) = returnUs (StgVarArg integerMinusOneId, emptyBag) - - | otherwise - = newStgVar integerTy `thenUs` \ var -> - let - rhs = StgRhsClosure noCostCentre -- No cost centre (ToDo?) - stgArgOcc -- safe - bOGUS_FVs - Updatable -- Update an integer - [] -- No arguments - val - - val - | i > tARGET_MIN_INT && i < tARGET_MAX_INT - = -- Start from an Int - StgPrim Int2IntegerOp [StgLitArg (mkMachInt i)] bOGUS_LVs - - | otherwise - = -- Start from a string - StgPrim Addr2IntegerOp [StgLitArg (MachStr (_PK_ (show i)))] bOGUS_LVs - in - returnUs (StgVarArg var, unitBag (StgNonRec var rhs)) - -litToStgArg (NoRepRational r) - = litToStgArg (NoRepInteger (numerator r)) `thenUs` \ (num_atom, binds1) -> - litToStgArg (NoRepInteger (denominator r)) `thenUs` \ (denom_atom, binds2) -> - newStgVar rationalTy `thenUs` \ var -> - let - rhs = StgRhsCon noCostCentre -- No cost centre (ToDo?) - ratioDataCon -- Constructor - [num_atom, denom_atom] - in - returnUs (StgVarArg var, binds1 `unionBags` - binds2 `unionBags` - unitBag (StgNonRec var rhs)) - -litToStgArg other_lit = returnUs (StgLitArg other_lit, emptyBag) + arg_ty = exprType arg \end{code} %************************************************************************ %* * -\subsection[coreToStg-atoms{Converting atoms} +\subsection[coreToStg-exprs]{Converting core expressions} %* * %************************************************************************ \begin{code} -coreArgsToStg :: StgEnv -> [CoreArg] -> UniqSM ([Type], [StgArg], Bag StgBinding) - -coreArgsToStg env [] = returnUs ([], [], emptyBag) -coreArgsToStg env (a:as) - = coreArgsToStg env as `thenUs` \ (tys, args, binds) -> - do_arg a tys args binds - where - do_arg a trest vrest binds - = case a of - TyArg t -> returnUs (t:trest, vrest, binds) - UsageArg u -> returnUs (trest, vrest, binds) - VarArg v -> returnUs (trest, stgLookup env v : vrest, binds) - LitArg i -> litToStgArg i `thenUs` \ (v, bs) -> - returnUs (trest, v:vrest, bs `unionBags` binds) -\end{code} - -There's not anything interesting we can ASSERT about \tr{var} if it -isn't in the StgEnv. (WDP 94/06) -\begin{code} -stgLookup :: StgEnv -> Id -> StgArg - -stgLookup env var = case (lookupIdEnv env var) of - Nothing -> StgVarArg var - Just atom -> atom +coreExprToStg :: StgEnv -> CoreExpr -> UniqSM StgExpr +coreExprToStg env expr + = coreExprToStgFloat env expr `thenUs` \ (binds,stg_expr) -> + mkStgBinds binds stg_expr `thenUs` \ stg_expr' -> + deStgLam stg_expr' \end{code} %************************************************************************ %* * -\subsection[coreToStg-exprs]{Converting core expressions} +\subsubsection[coreToStg-let(rec)]{Let and letrec expressions} %* * %************************************************************************ \begin{code} -coreExprToStg :: StgEnv - -> CoreExpr - -> UniqSM (StgExpr, -- Result - Bag StgBinding) -- Float these to top level +coreExprToStgFloat :: StgEnv -> CoreExpr + -> UniqSM ([StgFloatBind], StgExpr) +-- Transform an expression to STG. The 'floats' are +-- any bindings we had to create for function arguments. \end{code} +Simple cases first + \begin{code} -coreExprToStg env (Lit lit) - = litToStgArg lit `thenUs` \ (atom, binds) -> - returnUs (StgApp atom [] bOGUS_LVs, binds) +coreExprToStgFloat env (Var var) + = mkStgApp env var [] (idType var) `thenUs` \ app -> + returnUs ([], app) -coreExprToStg env (Var var) - = returnUs (StgApp (stgLookup env var) [] bOGUS_LVs, emptyBag) +coreExprToStgFloat env (Lit lit) + = returnUs ([], StgLit lit) -coreExprToStg env (Con con args) - = coreArgsToStg env args `thenUs` \ (types, stg_atoms, stg_binds) -> - let - spec_con = mkSpecialisedCon con types - in - returnUs (StgCon spec_con stg_atoms bOGUS_LVs, stg_binds) +coreExprToStgFloat env (Let bind body) + = coreBindToStg NotTopLevel env bind `thenUs` \ (new_bind, new_env) -> + coreExprToStgFloat new_env body `thenUs` \ (floats, stg_body) -> + returnUs (new_bind:floats, stg_body) +\end{code} -coreExprToStg env (Prim op args) - = coreArgsToStg env args `thenUs` \ (_, stg_atoms, stg_binds) -> - returnUs (StgPrim op stg_atoms bOGUS_LVs, stg_binds) +Convert core @scc@ expression directly to STG @scc@ expression. + +\begin{code} +coreExprToStgFloat env (Note (SCC cc) expr) + = coreExprToStg env expr `thenUs` \ stg_expr -> + returnUs ([], StgSCC cc stg_expr) + +coreExprToStgFloat env (Note other_note expr) + = coreExprToStgFloat env expr +\end{code} + +\begin{code} +coreExprToStgFloat env expr@(Type _) + = pprPanic "coreExprToStgFloat: tyarg unexpected:" $ ppr expr \end{code} + %************************************************************************ %* * \subsubsection[coreToStg-lambdas]{Lambda abstractions} @@ -422,23 +427,31 @@ coreExprToStg env (Prim op args) %************************************************************************ \begin{code} -coreExprToStg env expr@(Lam _ _) +coreExprToStgFloat env expr@(Lam _ _) = let - (_,_, binders, body) = collectBinders expr + expr_ty = exprType expr + (binders, body) = collectBinders expr + id_binders = filter isId binders in - coreExprToStg env body `thenUs` \ (stg_body, binds) -> - newStgVar (coreExprType expr) `thenUs` \ var -> - returnUs - (StgLet (StgNonRec var (StgRhsClosure noCostCentre - stgArgOcc - bOGUS_FVs - ReEntrant -- binders is non-empty - binders - stg_body)) - (StgApp (StgVarArg var) [] bOGUS_LVs), - binds) + if null id_binders then -- It was all type/usage binders; tossed + coreExprToStgFloat env body + else + -- At least some value binders + newLocalIds NotTopLevel env id_binders `thenUs` \ (env', binders') -> + coreExprToStgFloat env' body `thenUs` \ (floats, stg_body) -> + mkStgBinds floats stg_body `thenUs` \ stg_body' -> + + case stg_body' of + StgLam ty lam_bndrs lam_body -> + -- If the body reduced to a lambda too, join them up + returnUs ([], mkStgLam expr_ty (binders' ++ lam_bndrs) lam_body) + + other -> + -- Body didn't reduce to a lambda, so return one + returnUs ([], mkStgLam expr_ty binders' stg_body') \end{code} + %************************************************************************ %* * \subsubsection[coreToStg-applications]{Applications} @@ -446,198 +459,465 @@ coreExprToStg env expr@(Lam _ _) %************************************************************************ \begin{code} -coreExprToStg env expr@(App _ _) +coreExprToStgFloat env expr@(App _ _) = let - (fun, _, _, args) = collectArgs expr + (fun,rads,ty,ss) = collect_args expr + ads = reverse rads + final_ads | null ss = ads + | otherwise = zap ads -- Too few args to satisfy strictness info + -- so we have to ignore all the strictness info + -- e.g. + (error "urk") + -- Here, we can't evaluate the arg strictly, + -- because this partial application might be seq'd in - -- Deal with the arguments - coreArgsToStg env args `thenUs` \ (_, stg_args, arg_binds) -> + coreArgsToStg env final_ads `thenUs` \ (arg_floats, stg_args) -> -- Now deal with the function - case fun of - Var fun_id -> returnUs (StgApp (stgLookup env fun_id) stg_args bOGUS_LVs, arg_binds) + case (fun, stg_args) of + (Var fn_id, _) -> -- A function Id, so do an StgApp; it's ok if + -- there are no arguments. + mkStgApp env fn_id stg_args ty `thenUs` \ app -> + returnUs (arg_floats, app) + + (non_var_fun, []) -> -- No value args, so recurse into the function + ASSERT( null arg_floats ) + coreExprToStgFloat env non_var_fun other -> -- A non-variable applied to things; better let-bind it. - newStgVar (coreExprType fun) `thenUs` \ fun_id -> - coreExprToStg env fun `thenUs` \ (stg_fun, fun_binds) -> - let - fun_rhs = StgRhsClosure noCostCentre -- No cost centre (ToDo?) - stgArgOcc - bOGUS_FVs - SingleEntry -- Only entered once - [] - stg_fun - in - returnUs (StgLet (StgNonRec fun_id fun_rhs) - (StgApp (StgVarArg fun_id) stg_args bOGUS_LVs), - arg_binds `unionBags` fun_binds) + newStgVar (exprType fun) `thenUs` \ fn_id -> + coreExprToStgFloat env fun `thenUs` \ (fun_floats, stg_fun) -> + mkStgApp env fn_id stg_args ty `thenUs` \ app -> + returnUs (NonRecF fn_id stg_fun onceDem fun_floats : arg_floats, + app) + + where + -- Collect arguments and demands (*in reverse order*) + -- collect_args e = (f, args_w_demands, ty, stricts) + -- => e = f tys args, (i.e. args are just the value args) + -- e :: ty + -- stricts is the leftover demands of e on its further args + -- If stricts runs out, we zap all the demands in args_w_demands + -- because partial applications are lazy + + collect_args :: CoreExpr -> (CoreExpr, [(CoreExpr,RhsDemand)], Type, [Demand]) + + collect_args (Note (Coerce ty _) e) = let (the_fun,ads,_,ss) = collect_args e + in (the_fun,ads,ty,ss) + collect_args (Note InlineCall e) = collect_args e + collect_args (Note (TermUsg _) e) = collect_args e + + collect_args (App fun (Type tyarg)) = let (the_fun,ads,fun_ty,ss) = collect_args fun + in (the_fun,ads,applyTy fun_ty tyarg,ss) + collect_args (App fun arg) + = (the_fun, (arg, mkDemTy ss1 arg_ty) : ads, res_ty, ss_rest) + where + (ss1, ss_rest) = case ss of + (ss1:ss_rest) -> (ss1, ss_rest) + [] -> (wwLazy, []) + (the_fun, ads, fun_ty, ss) = collect_args fun + (arg_ty, res_ty) = expectJust "coreExprToStgFloat:collect_args" $ + splitFunTy_maybe fun_ty + + collect_args (Var v) + = (Var v, [], idType v, stricts) + where + stricts = case idStrictness v of + StrictnessInfo demands _ -> demands + other -> repeat wwLazy + + collect_args fun = (fun, [], exprType fun, repeat wwLazy) + + -- "zap" nukes the strictness info for a partial application + zap ads = [(arg, RhsDemand False once) | (arg, RhsDemand _ once) <- ads] \end{code} + %************************************************************************ %* * \subsubsection[coreToStg-cases]{Case expressions} %* * %************************************************************************ -At this point, we *mangle* cases involving fork# and par# in the -discriminant. The original templates for these primops (see -@PrelVals.lhs@) constructed case expressions with boolean results -solely to fool the strictness analyzer, the simplifier, and anyone -else who might want to fool with the evaluation order. Now, we -believe that once the translation to STG code is performed, our -evaluation order is safe. Therefore, we convert expressions of the -form: - - case par# e of - True -> rhs - False -> parError# - -to - - case par# e of - _ -> rhs - \begin{code} - -coreExprToStg env (Case discrim@(Prim op _) alts) - | funnyParallelOp op - = getUnique `thenUs` \ uniq -> - coreExprToStg env discrim `thenUs` \ (stg_discrim, discrim_binds) -> - alts_to_stg alts `thenUs` \ (stg_alts, alts_binds) -> - returnUs ( - StgCase stg_discrim - bOGUS_LVs - bOGUS_LVs - uniq - stg_alts, - discrim_binds `unionBags` alts_binds - ) +coreExprToStgFloat env (Case scrut bndr alts) + = coreExprToStgFloat env scrut `thenUs` \ (binds, scrut') -> + newLocalId NotTopLevel env bndr `thenUs` \ (env', bndr') -> + alts_to_stg env' (findDefault alts) `thenUs` \ alts' -> + mkStgCase scrut' bndr' alts' `thenUs` \ expr' -> + returnUs (binds, expr') where - funnyParallelOp SeqOp = True - funnyParallelOp ParOp = True - funnyParallelOp ForkOp = True - funnyParallelOp _ = False - - discrim_ty = coreExprType discrim - - alts_to_stg (PrimAlts _ (BindDefault binder rhs)) - = coreExprToStg env rhs `thenUs` \ (stg_rhs, rhs_binds) -> - let - stg_deflt = StgBindDefault binder False stg_rhs - in - returnUs (StgPrimAlts discrim_ty [] stg_deflt, rhs_binds) - --- OK, back to real life... - -coreExprToStg env (Case discrim alts) - = coreExprToStg env discrim `thenUs` \ (stg_discrim, discrim_binds) -> - alts_to_stg discrim alts `thenUs` \ (stg_alts, alts_binds) -> - getUnique `thenUs` \ uniq -> - returnUs ( - StgCase stg_discrim - bOGUS_LVs - bOGUS_LVs - uniq - stg_alts, - discrim_binds `unionBags` alts_binds - ) - where - discrim_ty = coreExprType discrim - (_, discrim_ty_args, _) = getAppDataTyCon discrim_ty - - alts_to_stg discrim (AlgAlts alts deflt) - = default_to_stg discrim deflt `thenUs` \ (stg_deflt, deflt_binds) -> - mapAndUnzipUs boxed_alt_to_stg alts `thenUs` \ (stg_alts, alts_binds) -> - returnUs (StgAlgAlts discrim_ty stg_alts stg_deflt, - deflt_binds `unionBags` unionManyBags alts_binds) - where - boxed_alt_to_stg (con, bs, rhs) - = coreExprToStg env rhs `thenUs` \ (stg_rhs, rhs_binds) -> - returnUs ((spec_con, bs, [ True | b <- bs ]{-bogus use mask-}, stg_rhs), - rhs_binds) - where - spec_con = mkSpecialisedCon con discrim_ty_args - - alts_to_stg discrim (PrimAlts alts deflt) - = default_to_stg discrim deflt `thenUs` \ (stg_deflt,deflt_binds) -> - mapAndUnzipUs unboxed_alt_to_stg alts `thenUs` \ (stg_alts, alts_binds) -> - returnUs (StgPrimAlts discrim_ty stg_alts stg_deflt, - deflt_binds `unionBags` unionManyBags alts_binds) - where - unboxed_alt_to_stg (lit, rhs) - = coreExprToStg env rhs `thenUs` \ (stg_rhs, rhs_binds) -> - returnUs ((lit, stg_rhs), rhs_binds) - - default_to_stg discrim NoDefault - = returnUs (StgNoDefault, emptyBag) - - default_to_stg discrim (BindDefault binder rhs) - = coreExprToStg new_env rhs `thenUs` \ (stg_rhs, rhs_binds) -> - returnUs (StgBindDefault binder True{-used? no it is lying-} stg_rhs, - rhs_binds) - where - -- - -- We convert case x of {...; x' -> ...x'...} - -- to - -- case x of {...; _ -> ...x... } - -- - -- See notes in SimplCase.lhs, near simplDefault for the reasoning. - -- It's quite easily done: simply extend the environment to bind the - -- default binder to the scrutinee. - -- - new_env = case discrim of - Var v -> addOneToIdEnv env binder (stgLookup env v) - other -> env + scrut_ty = idType bndr + prim_case = isUnLiftedType scrut_ty && not (isUnboxedTupleType scrut_ty) + + alts_to_stg env (alts, deflt) + | prim_case + = default_to_stg env deflt `thenUs` \ deflt' -> + mapUs (prim_alt_to_stg env) alts `thenUs` \ alts' -> + returnUs (mkStgPrimAlts scrut_ty alts' deflt') + + | otherwise + = default_to_stg env deflt `thenUs` \ deflt' -> + mapUs (alg_alt_to_stg env) alts `thenUs` \ alts' -> + returnUs (mkStgAlgAlts scrut_ty alts' deflt') + + alg_alt_to_stg env (DataAlt con, bs, rhs) + = newLocalIds NotTopLevel env (filter isId bs) `thenUs` \ (env', stg_bs) -> + coreExprToStg env' rhs `thenUs` \ stg_rhs -> + returnUs (con, stg_bs, [ True | b <- stg_bs ]{-bogus use mask-}, stg_rhs) + -- NB the filter isId. Some of the binders may be + -- existential type variables, which STG doesn't care about + + prim_alt_to_stg env (LitAlt lit, args, rhs) + = ASSERT( null args ) + coreExprToStg env rhs `thenUs` \ stg_rhs -> + returnUs (lit, stg_rhs) + + default_to_stg env Nothing + = returnUs StgNoDefault + + default_to_stg env (Just rhs) + = coreExprToStg env rhs `thenUs` \ stg_rhs -> + returnUs (StgBindDefault stg_rhs) + -- The binder is used for prim cases and not otherwise + -- (hack for old code gen) \end{code} + %************************************************************************ %* * -\subsubsection[coreToStg-let(rec)]{Let and letrec expressions} +\subsection[coreToStg-misc]{Miscellaneous helping functions} %* * %************************************************************************ +There's not anything interesting we can ASSERT about \tr{var} if it +isn't in the StgEnv. (WDP 94/06) + +Invent a fresh @Id@: \begin{code} -coreExprToStg env (Let bind body) - = coreBindToStg env bind `thenUs` \ (stg_binds, new_env, float_binds1) -> - coreExprToStg new_env body `thenUs` \ (stg_body, float_binds2) -> - returnUs (mkStgLets stg_binds stg_body, float_binds1 `unionBags` float_binds2) +newStgVar :: Type -> UniqSM Id +newStgVar ty + = getUniqueUs `thenUs` \ uniq -> + seqType ty `seq` + returnUs (mkSysLocal SLIT("stg") uniq ty) \end{code} +\begin{code} +newLocalId TopLevel env id + -- Don't clone top-level binders. MkIface relies on their + -- uniques staying the same, so it can snaffle IdInfo off the + -- STG ids to put in interface files. + = let + name = idName id + ty = idType id + in + name `seq` + seqType ty `seq` + returnUs (env, mkVanillaId name ty) -%************************************************************************ -%* * -\subsubsection[coreToStg-scc]{SCC expressions} -%* * -%************************************************************************ -Covert core @scc@ expression directly to STG @scc@ expression. -\begin{code} -coreExprToStg env (SCC cc expr) - = coreExprToStg env expr `thenUs` \ (stg_expr, binds) -> - returnUs (StgSCC (coreExprType expr) cc stg_expr, binds) +newLocalId NotTopLevel env id + = -- Local binder, give it a new unique Id. + getUniqueUs `thenUs` \ uniq -> + let + name = idName id + ty = idType id + new_id = mkVanillaId (setNameUnique name uniq) ty + new_env = extendVarEnv env id new_id + in + name `seq` + seqType ty `seq` + returnUs (new_env, new_id) + +newLocalIds :: TopLevelFlag -> StgEnv -> [Id] -> UniqSM (StgEnv, [Id]) +newLocalIds top_lev env [] + = returnUs (env, []) +newLocalIds top_lev env (b:bs) + = newLocalId top_lev env b `thenUs` \ (env', b') -> + newLocalIds top_lev env' bs `thenUs` \ (env'', bs') -> + returnUs (env'', b':bs') \end{code} %************************************************************************ %* * -\subsection[coreToStg-misc]{Miscellaneous helping functions} +\subsection{Building STG syn} %* * %************************************************************************ -Utilities. - -Invent a fresh @Id@: \begin{code} -newStgVar :: Type -> UniqSM Id -newStgVar ty - = getUnique `thenUs` \ uniq -> - returnUs (mkSysLocal SLIT("stg") uniq ty mkUnknownSrcLoc) +mkStgAlgAlts ty alts deflt = seqType ty `seq` StgAlgAlts ty alts deflt +mkStgPrimAlts ty alts deflt = seqType ty `seq` StgPrimAlts ty alts deflt +mkStgLam ty bndrs body = seqType ty `seq` StgLam ty bndrs body + +mkStgApp :: StgEnv -> Id -> [StgArg] -> Type -> UniqSM StgExpr + -- The type is the type of the entire application +mkStgApp env fn args ty + = case idFlavour fn_alias of + DataConId dc + -> saturate fn_alias args ty $ \ args' ty' -> + returnUs (StgConApp dc args') + + PrimOpId (CCallOp (CCall (DynamicTarget _) a b c)) + -- Sigh...make a guaranteed unique name for a dynamic ccall + -> saturate fn_alias args ty $ \ args' ty' -> + getUniqueUs `thenUs` \ u -> + returnUs (StgPrimApp (CCallOp (CCall (DynamicTarget u) a b c)) args' ty') + + PrimOpId op + -> saturate fn_alias args ty $ \ args' ty' -> + returnUs (StgPrimApp op args' ty') + + other -> returnUs (StgApp fn_alias args) + -- Force the lookup + where + fn_alias = case (lookupVarEnv env fn) of -- In case it's been cloned + Nothing -> fn + Just fn' -> fn' + +saturate :: Id -> [StgArg] -> Type -> ([StgArg] -> Type -> UniqSM StgExpr) -> UniqSM StgExpr + -- The type should be the type of (id args) +saturate fn args ty thing_inside + | excess_arity == 0 -- Saturated, so nothing to do + = thing_inside args ty + + | otherwise -- An unsaturated constructor or primop; eta expand it + = ASSERT2( excess_arity > 0 && excess_arity <= length arg_tys, + ppr fn <+> ppr args <+> ppr excess_arity <+> parens (ppr ty) <+> ppr arg_tys ) + mapUs newStgVar extra_arg_tys `thenUs` \ arg_vars -> + thing_inside (args ++ map StgVarArg arg_vars) final_res_ty `thenUs` \ body -> + returnUs (StgLam ty arg_vars body) + where + fn_arity = idArity fn + excess_arity = fn_arity - length args + (arg_tys, res_ty) = splitRepFunTys ty + extra_arg_tys = take excess_arity arg_tys + final_res_ty = mkFunTys (drop excess_arity arg_tys) res_ty \end{code} \begin{code} -mkStgLets :: [StgBinding] - -> StgExpr -- body of let - -> StgExpr +-- Stg doesn't have a lambda *expression* +deStgLam (StgLam ty bndrs body) + -- Try for eta reduction + = ASSERT( not (null bndrs) ) + case eta body of + Just e -> -- Eta succeeded + returnUs e + + Nothing -> -- Eta failed, so let-bind the lambda + newStgVar ty `thenUs` \ fn -> + returnUs (StgLet (StgNonRec fn lam_closure) (StgApp fn [])) + where + lam_closure = StgRhsClosure noCCS + stgArgOcc + noSRT + bOGUS_FVs + ReEntrant -- binders is non-empty + bndrs + body + + eta (StgApp f args) + | n_remaining >= 0 && + and (zipWith ok bndrs last_args) && + notInExpr bndrs remaining_expr + = Just remaining_expr + where + remaining_expr = StgApp f remaining_args + (remaining_args, last_args) = splitAt n_remaining args + n_remaining = length args - length bndrs + + eta (StgLet bind@(StgNonRec b r) body) + | notInRhs bndrs r = case eta body of + Just e -> Just (StgLet bind e) + Nothing -> Nothing + + eta _ = Nothing + + ok bndr (StgVarArg arg) = bndr == arg + ok bndr other = False + +deStgLam expr = returnUs expr + + +-------------------------------------------------- +notInExpr :: [Id] -> StgExpr -> Bool +notInExpr vs (StgApp f args) = notInId vs f && notInArgs vs args +notInExpr vs (StgLet (StgNonRec b r) body) = notInRhs vs r && notInExpr vs body +notInExpr vs other = False -- Safe + +notInRhs :: [Id] -> StgRhs -> Bool +notInRhs vs (StgRhsCon _ _ args) = notInArgs vs args +notInRhs vs (StgRhsClosure _ _ _ _ _ _ body) = notInExpr vs body + -- Conservative: we could delete the binders from vs, but + -- cloning means this will never help + +notInArgs :: [Id] -> [StgArg] -> Bool +notInArgs vs args = all ok args + where + ok (StgVarArg v) = notInId vs v + ok (StgLitArg l) = True + +notInId :: [Id] -> Id -> Bool +notInId vs v = not (v `elem` vs) + + + +mkStgBinds :: [StgFloatBind] + -> StgExpr -- *Can* be a StgLam + -> UniqSM StgExpr -- *Can* be a StgLam + +mkStgBinds [] body = returnUs body +mkStgBinds (b:bs) body + = deStgLam body `thenUs` \ body' -> + go (b:bs) body' + where + go [] body = returnUs body + go (b:bs) body = go bs body `thenUs` \ body' -> + mkStgBind b body' + +-- The 'body' arg of mkStgBind can't be a StgLam +mkStgBind NoBindF body = returnUs body +mkStgBind (RecF prs) body = returnUs (StgLet (StgRec prs) body) + +mkStgBind (NonRecF bndr rhs dem floats) body +#ifdef DEBUG + -- We shouldn't get let or case of the form v=w + = case rhs of + StgApp v [] -> pprTrace "mkStgLet" (ppr bndr <+> ppr v) + (mk_stg_let bndr rhs dem floats body) + other -> mk_stg_let bndr rhs dem floats body + +mk_stg_let bndr rhs dem floats body +#endif + | isUnLiftedType bndr_rep_ty -- Use a case/PrimAlts + = ASSERT( not (isUnboxedTupleType bndr_rep_ty) ) + mkStgCase rhs bndr (StgPrimAlts bndr_rep_ty [] (StgBindDefault body)) `thenUs` \ expr' -> + mkStgBinds floats expr' + + | is_whnf + = if is_strict then + -- Strict let with WHNF rhs + mkStgBinds floats $ + StgLet (StgNonRec bndr (exprToRhs dem NotTopLevel rhs)) body + else + -- Lazy let with WHNF rhs; float until we find a strict binding + let + (floats_out, floats_in) = splitFloats floats + in + mkStgBinds floats_in rhs `thenUs` \ new_rhs -> + mkStgBinds floats_out $ + StgLet (StgNonRec bndr (exprToRhs dem NotTopLevel new_rhs)) body + + | otherwise -- Not WHNF + = if is_strict then + -- Strict let with non-WHNF rhs + mkStgCase rhs bndr (StgAlgAlts bndr_rep_ty [] (StgBindDefault body)) `thenUs` \ expr' -> + mkStgBinds floats expr' + else + -- Lazy let with non-WHNF rhs, so keep the floats in the RHS + mkStgBinds floats rhs `thenUs` \ new_rhs -> + returnUs (StgLet (StgNonRec bndr (exprToRhs dem NotTopLevel new_rhs)) body) + + where + bndr_rep_ty = repType (idType bndr) + is_strict = isStrictDem dem + is_whnf = case rhs of + StgConApp _ _ -> True + StgLam _ _ _ -> True + other -> False + +-- Split at the first strict binding +splitFloats fs@(NonRecF _ _ dem _ : _) + | isStrictDem dem = ([], fs) + +splitFloats (f : fs) = case splitFloats fs of + (fs_out, fs_in) -> (f : fs_out, fs_in) + +splitFloats [] = ([], []) +\end{code} + -mkStgLets binds body = foldr StgLet body binds +Making an STG case +~~~~~~~~~~~~~~~~~~ + +First, two special cases. We mangle cases involving + par# and seq# +inthe scrutinee. + +Up to this point, seq# will appear like this: + + case seq# e of + 0# -> seqError# + _ -> + +This code comes from an unfolding for 'seq' in Prelude.hs. +The 0# branch is purely to bamboozle the strictness analyser. +For example, if is strict in x, and there was no seqError# +branch, the strictness analyser would conclude that the whole expression +was strict in x, and perhaps evaluate x first -- but that would be a DISASTER. + +Now that the evaluation order is safe, we translate this into + + case e of + _ -> ... + +This used to be done in the post-simplification phase, but we need +unfoldings involving seq# to appear unmangled in the interface file, +hence we do this mangling here. + +Similarly, par# has an unfolding in PrelConc.lhs that makes it show +up like this: + + case par# e of + 0# -> rhs + _ -> parError# + + + ==> + case par# e of + _ -> rhs + +fork# isn't handled like this - it's an explicit IO operation now. +The reason is that fork# returns a ThreadId#, which gets in the +way of the above scheme. And anyway, IO is the only guaranteed +way to enforce ordering --SDM. + + +\begin{code} +-- Discard alernatives in case (par# ..) of +mkStgCase scrut@(StgPrimApp ParOp _ _) bndr + (StgPrimAlts ty _ deflt@(StgBindDefault _)) + = returnUs (StgCase scrut bOGUS_LVs bOGUS_LVs bndr noSRT (StgPrimAlts ty [] deflt)) + +mkStgCase (StgPrimApp SeqOp [scrut] _) bndr + (StgPrimAlts _ _ deflt@(StgBindDefault rhs)) + = mkStgCase scrut_expr new_bndr new_alts + where + new_alts | isUnLiftedType scrut_ty = WARN( True, text "mkStgCase" ) StgPrimAlts scrut_ty [] deflt + | otherwise = StgAlgAlts scrut_ty [] deflt + scrut_ty = stgArgType scrut + new_bndr = setIdType bndr scrut_ty + -- NB: SeqOp :: forall a. a -> Int# + -- So bndr has type Int# + -- But now we are going to scrutinise the SeqOp's argument directly, + -- so we must change the type of the case binder to match that + -- of the argument expression e. + + scrut_expr = case scrut of + StgVarArg v -> StgApp v [] + -- Others should not happen because + -- seq of a value should have disappeared + StgLitArg l -> WARN( True, text "seq on" <+> ppr l ) StgLit l + +mkStgCase scrut bndr alts + = deStgLam scrut `thenUs` \ scrut' -> + -- It is (just) possible to get a lambda as a srutinee here + -- Namely: fromDyn (toDyn ((+1)::Int->Int)) False) + -- gives: case ...Bool == Int->Int... of + -- True -> case coerce Bool (\x -> + 1 x) of + -- True -> ... + -- False -> ... + -- False -> ... + -- The True branch of the outer case will never happen, of course. + + returnUs (StgCase scrut' bOGUS_LVs bOGUS_LVs bndr noSRT alts) \end{code}