X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FstgSyn%2FCoreToStg.lhs;h=824cabaacbd51c1468cf5ea6d56c8143c3a5edfc;hb=28a464a75e14cece5db40f2765a29348273ff2d2;hp=15e9fc3cd65015eda357ce509949fe69b17a60ae;hpb=1cfc9faaa059b9b090971399e4eb8ae9d364335c;p=ghc-hetmet.git diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs index 15e9fc3..824caba 100644 --- a/ghc/compiler/stgSyn/CoreToStg.lhs +++ b/ghc/compiler/stgSyn/CoreToStg.lhs @@ -12,14 +12,14 @@ module CoreToStg ( coreToStg, coreExprToStg ) where #include "HsVersions.h" import CoreSyn -import CoreUtils ( rhsIsStatic, manifestArity, exprType ) +import CoreUtils ( rhsIsStatic, manifestArity, exprType, findDefault ) import StgSyn import Type import TyCon ( isAlgTyCon ) -import Literal import Id -import Var ( Var, globalIdDetails, varType ) +import Var ( Var, globalIdDetails, idType ) +import TyCon ( isUnboxedTupleTyCon, isPrimTyCon, isFunTyCon, isHiBootTyCon ) #ifdef ILX import MkId ( unsafeCoerceId ) #endif @@ -30,9 +30,10 @@ import VarSet import VarEnv import Maybes ( maybeToBool ) import Name ( getOccName, isExternalName, nameOccName ) -import OccName ( occNameUserString, occNameFS ) +import OccName ( occNameString, occNameFS ) import BasicTypes ( Arity ) -import CmdLineOpts ( DynFlags, opt_RuntimeTypes ) +import Packages ( HomeModules ) +import StaticFlags ( opt_RuntimeTypes ) import Outputable infixr 9 `thenLne` @@ -139,10 +140,10 @@ for x, solely to put in the SRTs lower down. %************************************************************************ \begin{code} -coreToStg :: DynFlags -> [CoreBind] -> IO [StgBinding] -coreToStg dflags pgm +coreToStg :: HomeModules -> [CoreBind] -> IO [StgBinding] +coreToStg hmods pgm = return pgm' - where (_, _, pgm') = coreTopBindsToStg emptyVarEnv pgm + where (_, _, pgm') = coreTopBindsToStg hmods emptyVarEnv pgm coreExprToStg :: CoreExpr -> StgExpr coreExprToStg expr @@ -150,33 +151,35 @@ coreExprToStg expr coreTopBindsToStg - :: IdEnv HowBound -- environment for the bindings + :: HomeModules + -> IdEnv HowBound -- environment for the bindings -> [CoreBind] -> (IdEnv HowBound, FreeVarsInfo, [StgBinding]) -coreTopBindsToStg env [] = (env, emptyFVInfo, []) -coreTopBindsToStg env (b:bs) +coreTopBindsToStg hmods env [] = (env, emptyFVInfo, []) +coreTopBindsToStg hmods env (b:bs) = (env2, fvs2, b':bs') where -- env accumulates down the list of binds, fvs accumulates upwards - (env1, fvs2, b' ) = coreTopBindToStg env fvs1 b - (env2, fvs1, bs') = coreTopBindsToStg env1 bs + (env1, fvs2, b' ) = coreTopBindToStg hmods env fvs1 b + (env2, fvs1, bs') = coreTopBindsToStg hmods env1 bs coreTopBindToStg - :: IdEnv HowBound + :: HomeModules + -> IdEnv HowBound -> FreeVarsInfo -- Info about the body -> CoreBind -> (IdEnv HowBound, FreeVarsInfo, StgBinding) -coreTopBindToStg env body_fvs (NonRec id rhs) +coreTopBindToStg hmods env body_fvs (NonRec id rhs) = let env' = extendVarEnv env id how_bound - how_bound = LetBound TopLet (manifestArity rhs) + how_bound = LetBound TopLet $! manifestArity rhs (stg_rhs, fvs') = initLne env ( - coreToTopStgRhs body_fvs (id,rhs) `thenLne` \ (stg_rhs, fvs') -> + coreToTopStgRhs hmods body_fvs (id,rhs) `thenLne` \ (stg_rhs, fvs') -> returnLne (stg_rhs, fvs') ) @@ -187,17 +190,17 @@ coreTopBindToStg env body_fvs (NonRec id rhs) -- WARN(not (consistent caf_info bind), ppr id <+> ppr cafs <+> ppCafInfo caf_info) (env', fvs' `unionFVInfo` body_fvs, bind) -coreTopBindToStg env body_fvs (Rec pairs) +coreTopBindToStg hmods env body_fvs (Rec pairs) = let (binders, rhss) = unzip pairs - extra_env' = [ (b, LetBound TopLet (manifestArity rhs)) + extra_env' = [ (b, LetBound TopLet $! manifestArity rhs) | (b, rhs) <- pairs ] env' = extendVarEnvList env extra_env' (stg_rhss, fvs') = initLne env' ( - mapAndUnzipLne (coreToTopStgRhs body_fvs) pairs + mapAndUnzipLne (coreToTopStgRhs hmods body_fvs) pairs `thenLne` \ (stg_rhss, fvss') -> let fvs' = unionFVInfos fvss' in returnLne (stg_rhss, fvs') @@ -229,17 +232,18 @@ consistentCafInfo id bind \begin{code} coreToTopStgRhs - :: FreeVarsInfo -- Free var info for the scope of the binding + :: HomeModules + -> FreeVarsInfo -- Free var info for the scope of the binding -> (Id,CoreExpr) -> LneM (StgRhs, FreeVarsInfo) -coreToTopStgRhs scope_fv_info (bndr, rhs) +coreToTopStgRhs hmods scope_fv_info (bndr, rhs) = coreToStgExpr rhs `thenLne` \ (new_rhs, rhs_fvs, _) -> freeVarsToLiveVars rhs_fvs `thenLne` \ lv_info -> returnLne (mkTopStgRhs is_static rhs_fvs (mkSRT lv_info) bndr_info new_rhs, rhs_fvs) where bndr_info = lookupFVInfo scope_fv_info bndr - is_static = rhsIsStatic rhs + is_static = rhsIsStatic hmods rhs mkTopStgRhs :: Bool -> FreeVarsInfo -> SRT -> StgBinderInfo -> StgExpr -> StgRhs @@ -257,7 +261,7 @@ mkTopStgRhs is_static rhs_fvs srt binder_info (StgConApp con args) = StgRhsCon noCCS con args mkTopStgRhs is_static rhs_fvs srt binder_info rhs - = ASSERT( not is_static ) + = ASSERT2( not is_static, ppr rhs ) StgRhsClosure noCCS binder_info (getFVs rhs_fvs) Updatable @@ -330,10 +334,10 @@ coreToStgExpr (Note other_note expr) -- Cases require a little more real work. -coreToStgExpr (Case scrut bndr alts) +coreToStgExpr (Case scrut bndr _ alts) = extendVarEnvLne [(bndr, LambdaBound)] ( mapAndUnzip3Lne vars_alt alts `thenLne` \ (alts2, fvs_s, escs_s) -> - returnLne ( mkStgAlts (idType bndr) alts2, + returnLne ( alts2, unionFVInfos fvs_s, unionVarSets escs_s ) ) `thenLne` \ (alts2, alts_fvs, alts_escs) -> @@ -367,6 +371,7 @@ coreToStgExpr (Case scrut bndr alts) (getLiveVars alts_lv_info) bndr' (mkSRT alts_lv_info) + (mkStgAltType (idType bndr) alts) alts2, scrut_fvs `unionFVInfo` alts_fvs_wo_bndr, alts_escs_wo_bndr `unionVarSet` getFVSet scrut_fvs @@ -406,28 +411,29 @@ coreToStgExpr (Let bind body) \end{code} \begin{code} -mkStgAlts scrut_ty orig_alts - | is_prim_case = StgPrimAlts (tyConAppTyCon scrut_ty) prim_alts deflt - | otherwise = StgAlgAlts maybe_tycon alg_alts deflt - where - is_prim_case = isUnLiftedType scrut_ty && not (isUnboxedTupleType scrut_ty) - - prim_alts = [(lit, rhs) | (LitAlt lit, _, _, rhs) <- other_alts] - alg_alts = [(con, bndrs, use, rhs) | (DataAlt con, bndrs, use, rhs) <- other_alts] - - (other_alts, deflt) - = case orig_alts of -- DEFAULT is always first if it's there at all - (DEFAULT, _, _, rhs) : other_alts -> (other_alts, StgBindDefault rhs) - other -> (orig_alts, StgNoDefault) +mkStgAltType scrut_ty alts + = case splitTyConApp_maybe (repType scrut_ty) of + Just (tc,_) | isUnboxedTupleTyCon tc -> UbxTupAlt tc + | isPrimTyCon tc -> PrimAlt tc + | isHiBootTyCon tc -> look_for_better_tycon + | isAlgTyCon tc -> AlgAlt tc + | isFunTyCon tc -> PolyAlt + | otherwise -> pprPanic "mkStgAlts" (ppr tc) + Nothing -> PolyAlt - maybe_tycon = case alg_alts of - -- Get the tycon from the data con - (dc, _, _, _) : _rest -> Just (dataConTyCon dc) - - -- Otherwise just do your best - [] -> case splitTyConApp_maybe (repType scrut_ty) of - Just (tc,_) | isAlgTyCon tc -> Just tc - _other -> Nothing + where + -- Sometimes, the TyCon in the type of the scrutinee is an HiBootTyCon, + -- which may not have any constructors inside it. If so, then we + -- can get a better TyCon by grabbing the one from a constructor alternative + -- if one exists. + look_for_better_tycon + | ((DataAlt con, _, _) : _) <- data_alts = + AlgAlt (dataConTyCon con) + | otherwise = + ASSERT(null data_alts) + PolyAlt + where + (data_alts, _deflt) = findDefault alts \end{code} @@ -458,7 +464,7 @@ coreToStgApp maybe_thunk_body f args -- Here the free variables are "f", "x" AND the type variable "a" -- coreToStgArgs will deal with the arguments recursively if opt_RuntimeTypes then - fvs `unionFVInfo` tyvarFVInfo (tyVarsOfType (varType f)) + fvs `unionFVInfo` tyvarFVInfo (tyVarsOfType (idType f)) else fvs -- Mostly, the arity info of a function is in the fn's IdInfo @@ -682,7 +688,7 @@ coreToStgLet let_no_escape bind body is_join_var :: Id -> Bool -- A hack (used only for compiler debuggging) to tell if -- a variable started life as a join point ($j) -is_join_var j = occNameUserString (getOccName j) == "$j" +is_join_var j = occNameString (getOccName j) == "$j" \end{code} \begin{code} @@ -873,15 +879,7 @@ thenLne :: LneM a -> (a -> LneM b) -> LneM b thenLne m k env lvs_cont = k (m env lvs_cont) env lvs_cont -mapLne :: (a -> LneM b) -> [a] -> LneM [b] -mapLne f [] = returnLne [] -mapLne f (x:xs) - = f x `thenLne` \ r -> - mapLne f xs `thenLne` \ rs -> - returnLne (r:rs) - mapAndUnzipLne :: (a -> LneM (b,c)) -> [a] -> LneM ([b],[c]) - mapAndUnzipLne f [] = returnLne ([],[]) mapAndUnzipLne f (x:xs) = f x `thenLne` \ (r1, r2) -> @@ -889,7 +887,6 @@ mapAndUnzipLne f (x:xs) returnLne (r1:rs1, r2:rs2) mapAndUnzip3Lne :: (a -> LneM (b,c,d)) -> [a] -> LneM ([b],[c],[d]) - mapAndUnzip3Lne f [] = returnLne ([],[],[]) mapAndUnzip3Lne f (x:xs) = f x `thenLne` \ (r1, r2, r3) -> @@ -897,7 +894,6 @@ mapAndUnzip3Lne f (x:xs) returnLne (r1:rs1, r2:rs2, r3:rs3) mapAndUnzip4Lne :: (a -> LneM (b,c,d,e)) -> [a] -> LneM ([b],[c],[d],[e]) - mapAndUnzip4Lne f [] = returnLne ([],[],[],[]) mapAndUnzip4Lne f (x:xs) = f x `thenLne` \ (r1, r2, r3, r4) -> @@ -1043,12 +1039,12 @@ lookupFVInfo fvs id Just (_,_,info) -> info allFreeIds :: FreeVarsInfo -> [(Id,HowBound)] -- Both top level and non-top-level Ids -allFreeIds fvs = [(id,how_bound) | (id,how_bound,_) <- rngVarEnv fvs, isId id] +allFreeIds fvs = [(id,how_bound) | (id,how_bound,_) <- varEnvElts fvs, isId id] -- Non-top-level things only, both type variables and ids -- (type variables only if opt_RuntimeTypes) getFVs :: FreeVarsInfo -> [Var] -getFVs fvs = [id | (id, how_bound, _) <- rngVarEnv fvs, +getFVs fvs = [id | (id, how_bound, _) <- varEnvElts fvs, not (topLevelBound how_bound) ] getFVSet :: FreeVarsInfo -> VarSet