X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FstgSyn%2FCoreToStg.lhs;h=824cabaacbd51c1468cf5ea6d56c8143c3a5edfc;hb=28a464a75e14cece5db40f2765a29348273ff2d2;hp=8fdc00398f0afd7774b9a1cf23f3e8ef03c71fcf;hpb=1aeeeaf808e13a81bc79e3e0e26cbe11ff2196bd;p=ghc-hetmet.git diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs index 8fdc003..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 Id -import Var ( Var, globalIdDetails, varType ) -import TyCon ( isUnboxedTupleTyCon, isPrimTyCon, isFunTyCon ) +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 @@ -330,7 +334,7 @@ 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 ( alts2, @@ -367,7 +371,7 @@ coreToStgExpr (Case scrut bndr alts) (getLiveVars alts_lv_info) bndr' (mkSRT alts_lv_info) - (mkStgAltType (idType bndr)) + (mkStgAltType (idType bndr) alts) alts2, scrut_fvs `unionFVInfo` alts_fvs_wo_bndr, alts_escs_wo_bndr `unionVarSet` getFVSet scrut_fvs @@ -407,14 +411,29 @@ coreToStgExpr (Let bind body) \end{code} \begin{code} -mkStgAltType scrut_ty +mkStgAltType scrut_ty alts = case splitTyConApp_maybe (repType scrut_ty) of Just (tc,_) | isUnboxedTupleTyCon tc -> UbxTupAlt tc | isPrimTyCon tc -> PrimAlt tc - | isAlgTyCon tc -> AlgAlt tc + | isHiBootTyCon tc -> look_for_better_tycon + | isAlgTyCon tc -> AlgAlt tc | isFunTyCon tc -> PolyAlt | otherwise -> pprPanic "mkStgAlts" (ppr tc) Nothing -> PolyAlt + + 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} @@ -445,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 @@ -669,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} @@ -860,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) -> @@ -876,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) -> @@ -884,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) -> @@ -1030,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