X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FstgSyn%2FCoreToStg.lhs;h=4fda0268f628836c6f8bbf7d7f3530356cf7ed93;hb=ba16832735be750fbf6bd7a6c59d87e0cd176240;hp=3ed0d380905764fd2e22bd6da56d028db77fa8aa;hpb=5cf27e8f1731c52fe63a5b9615f927484164c61b;p=ghc-hetmet.git diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs index 3ed0d38..4fda026 100644 --- a/ghc/compiler/stgSyn/CoreToStg.lhs +++ b/ghc/compiler/stgSyn/CoreToStg.lhs @@ -9,13 +9,13 @@ Convert a @CoreSyntax@ program to a @StgSyntax@ program. - \begin{code} #include "HsVersions.h" module CoreToStg ( topCoreBindsToStg ) where -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} +IMPORT_1_3(Ratio(numerator,denominator)) import CoreSyn -- input import StgSyn -- output @@ -24,22 +24,25 @@ 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-} + externallyVisibleId, + + nullIdEnv, addOneToIdEnv, lookupIdEnv, growIdEnvList, + SYN_IE(IdEnv), GenId{-instance NamedThing-}, SYN_IE(Id) ) import Literal ( mkMachInt, Literal(..) ) -import Name ( isExported ) -import PrelInfo ( unpackCStringId, unpackCString2Id, stringTy, - integerTy, rationalTy, ratioDataCon, +import PrelVals ( unpackCStringId, unpackCString2Id, integerZeroId, integerPlusOneId, integerPlusTwoId, integerMinusOneId ) import PrimOp ( PrimOp(..) ) import SpecUtils ( mkSpecialisedCon ) -import SrcLoc ( mkUnknownSrcLoc ) -import Type ( getAppDataTyConExpandingDicts ) +import SrcLoc ( noSrcLoc ) +import TyCon ( TyCon{-instance Uniquable-} ) +import Type ( getAppDataTyConExpandingDicts, SYN_IE(Type) ) +import TysWiredIn ( stringTy ) +import Unique ( integerTyConKey, ratioTyConKey, Unique{-instance Eq-} ) import UniqSupply -- all of it, really -import Util ( panic ) +import Util ( zipLazy, panic, assertPanic{-, pprTrace ToDo:rm-} ) isLeakFreeType x y = False -- safe option; ToDo \end{code} @@ -55,17 +58,16 @@ The business of this pass is to convert Core to Stg. On the way: x = y t1 t2 where t1, t2 are types -* We make the representation of NoRep literals explicit, and - float their bindings to the top level +* 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] %************************************************************************ @@ -101,75 +103,15 @@ topCoreBindsToStg :: UniqSupply -- name supply -> [StgBinding] -- output topCoreBindsToStg us core_binds - = case (initUs us (binds_to_stg nullIdEnv core_binds)) of - (_, stuff) -> stuff + = initUs us (coreBindsToStg nullIdEnv 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... + coreBindsToStg :: StgEnv -> [CoreBinding] -> UniqSM [StgBinding] - is_liftable anything_else = False + coreBindsToStg env [] = returnUs [] + coreBindsToStg env (b:bs) + = coreBindToStg env b `thenUs` \ (new_b, new_env) -> + coreBindsToStg new_env bs `thenUs` \ new_bs -> + returnUs (new_b ++ new_bs) \end{code} %************************************************************************ @@ -182,34 +124,30 @@ topCoreBindsToStg us core_binds coreBindToStg :: StgEnv -> CoreBinding -> UniqSM ([StgBinding], -- Empty or singleton - StgEnv, -- New envt - Bag StgBinding) -- Floats + StgEnv) -- Floats coreBindToStg env (NonRec binder rhs) - = coreRhsToStg env rhs `thenUs` \ (stg_rhs, rhs_binds) -> - + = coreRhsToStg env rhs `thenUs` \ stg_rhs -> let -- Binds to return if RHS is trivial - triv_binds = if isExported binder then - [StgNonRec binder stg_rhs] -- Retain it - else - [] -- Discard it + triv_binds | externallyVisibleId binder = [StgNonRec binder stg_rhs] -- Retain it + | otherwise = [] -- 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) + returnUs (triv_binds, new_env) 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) + returnUs (triv_binds, new_env) where - new_env = addOneToIdEnv env binder (StgVarArg con_id) + new_env = addOneToIdEnv env binder (StgConArg con_id) other -> -- Non-trivial RHS, so don't augment envt - returnUs ([StgNonRec binder stg_rhs], env, rhs_binds) + returnUs ([StgNonRec binder stg_rhs], env) coreBindToStg env (Rec pairs) = -- NB: *** WE DO NOT CHECK FOR TRIV_BINDS in REC BIND **** @@ -217,8 +155,8 @@ coreBindToStg env (Rec pairs) 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) + mapUs (coreRhsToStg env) rhss `thenUs` \ stg_rhss -> + returnUs ([StgRec (binders `zip` stg_rhss)], env) \end{code} @@ -229,17 +167,18 @@ coreBindToStg env (Rec pairs) %************************************************************************ \begin{code} -coreRhsToStg :: StgEnv -> CoreExpr -> UniqSM (StgRhs, Bag StgBinding) +coreRhsToStg :: StgEnv -> CoreExpr -> UniqSM StgRhs coreRhsToStg env core_rhs - = coreExprToStg env core_rhs `thenUs` \ (stg_expr, stg_binds) -> + = coreExprToStg env core_rhs `thenUs` \ stg_expr -> 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 + -- incoming rhs. Why? Because trivial bindings might conceal + -- what the rhs is actually like. StgCon con args _ -> StgRhsCon noCostCentre con args @@ -250,102 +189,7 @@ coreRhsToStg env core_rhs [] stg_expr in - returnUs (stg_rhs, stg_binds) -\end{code} - - -%************************************************************************ -%* * -\subsection[coreToStg-lits]{Converting literals} -%* * -%************************************************************************ - -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. - -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@. - -\begin{code} -tARGET_MIN_INT, tARGET_MAX_INT :: Integer -tARGET_MIN_INT = -536870912 -tARGET_MAX_INT = 536870912 - -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)) - 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) + returnUs stg_rhs \end{code} @@ -356,31 +200,19 @@ litToStgArg other_lit = returnUs (StgLitArg other_lit, emptyBag) %************************************************************************ \begin{code} -coreArgsToStg :: StgEnv -> [CoreArg] -> UniqSM ([Type], [StgArg], Bag StgBinding) +coreArgsToStg :: StgEnv -> [CoreArg] -> ([Type], [StgArg]) -coreArgsToStg env [] = returnUs ([], [], emptyBag) +coreArgsToStg env [] = ([], []) coreArgsToStg env (a:as) - = coreArgsToStg env as `thenUs` \ (tys, args, binds) -> - do_arg a tys args binds + = case a of + TyArg t -> (t:trest, vrest) + UsageArg u -> (trest, vrest) + VarArg v -> (trest, stgLookup env v : vrest) + LitArg l -> (trest, StgLitArg l : vrest) 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) + (trest,vrest) = coreArgsToStg env as \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 -\end{code} %************************************************************************ %* * @@ -389,30 +221,26 @@ stgLookup env var = case (lookupIdEnv env var) of %************************************************************************ \begin{code} -coreExprToStg :: StgEnv - -> CoreExpr - -> UniqSM (StgExpr, -- Result - Bag StgBinding) -- Float these to top level -\end{code} +coreExprToStg :: StgEnv -> CoreExpr -> UniqSM StgExpr -\begin{code} coreExprToStg env (Lit lit) - = litToStgArg lit `thenUs` \ (atom, binds) -> - returnUs (StgApp atom [] bOGUS_LVs, binds) + = returnUs (StgApp (StgLitArg lit) [] bOGUS_LVs) coreExprToStg env (Var var) - = returnUs (StgApp (stgLookup env var) [] bOGUS_LVs, emptyBag) + = returnUs (mk_app (stgLookup env var) []) coreExprToStg env (Con con args) - = coreArgsToStg env args `thenUs` \ (types, stg_atoms, stg_binds) -> - let + = let + (types, stg_atoms) = coreArgsToStg env args spec_con = mkSpecialisedCon con types in - returnUs (StgCon spec_con stg_atoms bOGUS_LVs, stg_binds) + returnUs (StgCon spec_con stg_atoms bOGUS_LVs) coreExprToStg env (Prim op args) - = coreArgsToStg env args `thenUs` \ (_, stg_atoms, stg_binds) -> - returnUs (StgPrim op stg_atoms bOGUS_LVs, stg_binds) + = let + (types, stg_atoms) = coreArgsToStg env args + in + returnUs (StgPrim op stg_atoms bOGUS_LVs) \end{code} %************************************************************************ @@ -426,17 +254,21 @@ coreExprToStg env expr@(Lam _ _) = let (_,_, binders, body) = collectBinders expr 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) + coreExprToStg env body `thenUs` \ stg_body -> + + if null binders then -- it was all type/usage binders; tossed + returnUs stg_body + else + 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)) \end{code} %************************************************************************ @@ -448,18 +280,22 @@ coreExprToStg env expr@(Lam _ _) \begin{code} coreExprToStg env expr@(App _ _) = let - (fun, _, _, args) = collectArgs expr + (fun,args) = collect_args expr [] + (_, stg_args) = coreArgsToStg env args in - -- Deal with the arguments - coreArgsToStg env args `thenUs` \ (_, stg_args, arg_binds) -> - -- 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, args) of + (Var fun_id, _) -> -- A function Id, so do an StgApp; it's ok if + -- there are no arguments. + returnUs (mk_app (stgLookup env fun_id) stg_args) + + (non_var_fun, []) -> -- No value args, so recurse into the function + coreExprToStg env non_var_fun other -> -- A non-variable applied to things; better let-bind it. +-- pprTrace "coreExprToStg" (ppr PprDebug expr) $ newStgVar (coreExprType fun) `thenUs` \ fun_id -> - coreExprToStg env fun `thenUs` \ (stg_fun, fun_binds) -> + coreExprToStg env fun `thenUs` \ (stg_fun) -> let fun_rhs = StgRhsClosure noCostCentre -- No cost centre (ToDo?) stgArgOcc @@ -469,8 +305,14 @@ coreExprToStg env expr@(App _ _) stg_fun in returnUs (StgLet (StgNonRec fun_id fun_rhs) - (StgApp (StgVarArg fun_id) stg_args bOGUS_LVs), - arg_binds `unionBags` fun_binds) + (StgApp (StgVarArg fun_id) stg_args bOGUS_LVs)) + where + -- Collect arguments, discarding type/usage applications + collect_args (App e (TyArg _)) args = collect_args e args + collect_args (App e (UsageArg _)) args = collect_args e args + collect_args (App fun arg) args = collect_args fun (arg:args) + collect_args (Coerce _ _ expr) args = collect_args expr args + collect_args fun args = (fun, args) \end{code} %************************************************************************ @@ -479,115 +321,48 @@ coreExprToStg env expr@(App _ _) %* * %************************************************************************ -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 - ) - 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) -> + = coreExprToStg env discrim `thenUs` \ stg_discrim -> + alts_to_stg discrim alts `thenUs` \ stg_alts -> getUnique `thenUs` \ uniq -> returnUs ( StgCase stg_discrim bOGUS_LVs bOGUS_LVs uniq - stg_alts, - discrim_binds `unionBags` alts_binds + stg_alts ) where discrim_ty = coreExprType discrim (_, discrim_ty_args, _) = getAppDataTyConExpandingDicts 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) + = default_to_stg discrim deflt `thenUs` \ stg_deflt -> + mapUs boxed_alt_to_stg alts `thenUs` \ stg_alts -> + returnUs (StgAlgAlts discrim_ty stg_alts stg_deflt) 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) + = coreExprToStg env rhs `thenUs` \ stg_rhs -> + returnUs (spec_con, bs, [ True | b <- bs ]{-bogus use mask-}, stg_rhs) 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) + = default_to_stg discrim deflt `thenUs` \ stg_deflt -> + mapUs unboxed_alt_to_stg alts `thenUs` \ stg_alts -> + returnUs (StgPrimAlts discrim_ty stg_alts stg_deflt) where unboxed_alt_to_stg (lit, rhs) - = coreExprToStg env rhs `thenUs` \ (stg_rhs, rhs_binds) -> - returnUs ((lit, stg_rhs), rhs_binds) + = coreExprToStg env rhs `thenUs` \ stg_rhs -> + returnUs (lit, stg_rhs) default_to_stg discrim NoDefault - = returnUs (StgNoDefault, emptyBag) + = returnUs StgNoDefault 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 + = coreExprToStg env rhs `thenUs` \ stg_rhs -> + returnUs (StgBindDefault binder True{-used? no it is lying-} stg_rhs) \end{code} %************************************************************************ @@ -598,9 +373,9 @@ coreExprToStg env (Case discrim alts) \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) + = coreBindToStg env bind `thenUs` \ (stg_binds, new_env) -> + coreExprToStg new_env body `thenUs` \ stg_body -> + returnUs (mkStgLets stg_binds stg_body) \end{code} @@ -613,14 +388,12 @@ coreExprToStg env (Let bind body) 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) + = coreExprToStg env expr `thenUs` \ stg_expr -> + returnUs (StgSCC (coreExprType expr) cc stg_expr) \end{code} \begin{code} -coreExprToStg env (Coerce c ty expr) - = coreExprToStg env expr -- `thenUs` \ (stg_expr, binds) -> --- returnUs (StgSCC (coreExprType expr) cc stg_expr, binds) +coreExprToStg env (Coerce c ty expr) = coreExprToStg env expr \end{code} @@ -630,14 +403,22 @@ coreExprToStg env (Coerce c ty expr) %* * %************************************************************************ -Utilities. +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 +\end{code} Invent a fresh @Id@: \begin{code} newStgVar :: Type -> UniqSM Id newStgVar ty = getUnique `thenUs` \ uniq -> - returnUs (mkSysLocal SLIT("stg") uniq ty mkUnknownSrcLoc) + returnUs (mkSysLocal SLIT("stg") uniq ty noSrcLoc) \end{code} \begin{code} @@ -646,4 +427,10 @@ mkStgLets :: [StgBinding] -> StgExpr mkStgLets binds body = foldr StgLet body binds + +-- mk_app spots an StgCon in a function position, +-- and turns it into an StgCon. See notes with +-- getArgAmode in CgBindery. +mk_app (StgConArg con) args = StgCon con args bOGUS_LVs +mk_app other_fun args = StgApp other_fun args bOGUS_LVs \end{code}