X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FstgSyn%2FCoreToStg.lhs;h=6dd0255d605c7bb8aa4f7a514fcf42810085125f;hb=b5a73581d0c03b9d44a77706b5973d74074aa6c1;hp=13509cee94d3162de1d840c6ae34ed60f755733b;hpb=96d6d25b57d0a3f6b665d4d2255af111cf86c277;p=ghc-hetmet.git diff --git a/compiler/stgSyn/CoreToStg.lhs b/compiler/stgSyn/CoreToStg.lhs index 13509ce..6dd0255 100644 --- a/compiler/stgSyn/CoreToStg.lhs +++ b/compiler/stgSyn/CoreToStg.lhs @@ -12,13 +12,14 @@ module CoreToStg ( coreToStg, coreExprToStg ) where #include "HsVersions.h" import CoreSyn -import CoreUtils ( rhsIsStatic, manifestArity, exprType, findDefault ) +import CoreUtils ( rhsIsStatic, exprType, findDefault ) +import CoreArity ( manifestArity ) import StgSyn import Type import TyCon import Id -import Var ( Var, globalIdDetails, idType ) +import Var ( Var ) import IdInfo import DataCon import CostCentre ( noCCS ) @@ -156,11 +157,12 @@ coreTopBindsToStg _ env [] = (env, emptyFVInfo, []) coreTopBindsToStg this_pkg env (b:bs) = (env2, fvs2, b':bs') where - -- env accumulates down the list of binds, fvs accumulates upwards + -- Notice the mutually-recursive "knot" here: + -- env accumulates down the list of binds, + -- fvs accumulates upwards (env1, fvs2, b' ) = coreTopBindToStg this_pkg env fvs1 b (env2, fvs1, bs') = coreTopBindsToStg this_pkg env1 bs - coreTopBindToStg :: PackageId -> IdEnv HowBound @@ -180,14 +182,13 @@ coreTopBindToStg this_pkg env body_fvs (NonRec id rhs) bind = StgNonRec id stg_rhs in - ASSERT2(manifestArity rhs == stgRhsArity stg_rhs, ppr id $$ (ptext (sLit "rhs:")) <+> ppr rhs $$ (ptext (sLit "stg_rhs:"))<+> ppr stg_rhs $$ (ptext (sLit "Manifest:")) <+> (ppr $ manifestArity rhs) $$ (ptext (sLit "STG:")) <+>(ppr $ stgRhsArity stg_rhs) ) - ASSERT2(consistentCafInfo id bind, ppr id $$ ppr rhs $$ ppr bind) --- WARN(not (consistent caf_info bind), ppr id <+> ppr cafs <+> ppCafInfo caf_info) + ASSERT2(consistentCafInfo id bind, ppr id $$ ppr rhs $$ ppr bind ) (env', fvs' `unionFVInfo` body_fvs, bind) coreTopBindToStg this_pkg env body_fvs (Rec pairs) - = let - (binders, rhss) = unzip pairs + = ASSERT( not (null pairs) ) + let + binders = map fst pairs extra_env' = [ (b, LetBound TopLet $! manifestArity rhs) | (b, rhs) <- pairs ] @@ -201,10 +202,10 @@ coreTopBindToStg this_pkg env body_fvs (Rec pairs) bind = StgRec (zip binders stg_rhss) in - ASSERT2(and [manifestArity rhs == stgRhsArity stg_rhs | (rhs,stg_rhs) <- rhss `zip` stg_rhss], ppr binders) ASSERT2(consistentCafInfo (head binders) bind, ppr binders) (env', fvs' `unionFVInfo` body_fvs, bind) + -- Assertion helper: this checks that the CafInfo on the Id matches -- what CoreToStg has figured out about the binding's SRT. The -- CafInfo will be exact in all cases except when CorePrep has @@ -229,16 +230,40 @@ coreToTopStgRhs -> (Id,CoreExpr) -> LneM (StgRhs, FreeVarsInfo) -coreToTopStgRhs this_pkg scope_fv_info (bndr, rhs) = do - (new_rhs, rhs_fvs, _) <- coreToStgExpr rhs - lv_info <- freeVarsToLiveVars rhs_fvs - return (mkTopStgRhs is_static rhs_fvs (mkSRT lv_info) bndr_info new_rhs, rhs_fvs) +coreToTopStgRhs this_pkg scope_fv_info (bndr, rhs) + = do { (new_rhs, rhs_fvs, _) <- coreToStgExpr rhs + ; lv_info <- freeVarsToLiveVars rhs_fvs + + ; let stg_rhs = mkTopStgRhs is_static rhs_fvs (mkSRT lv_info) bndr_info new_rhs + stg_arity = stgRhsArity stg_rhs + ; return (ASSERT2( arity_ok stg_arity, mk_arity_msg stg_arity) stg_rhs, + rhs_fvs) } where bndr_info = lookupFVInfo scope_fv_info bndr is_static = rhsIsStatic this_pkg rhs -mkTopStgRhs :: Bool -> FreeVarsInfo -> SRT -> StgBinderInfo -> StgExpr - -> StgRhs + -- It's vital that the arity on a top-level Id matches + -- the arity of the generated STG binding, else an importing + -- module will use the wrong calling convention + -- (Trac #2844 was an example where this happened) + -- NB1: we can't move the assertion further out without + -- blocking the "knot" tied in coreTopBindsToStg + -- NB2: the arity check is only needed for Ids with External + -- Names, because they are externally visible. The CorePrep + -- pass introduces "sat" things with Local Names and does + -- not bother to set their Arity info, so don't fail for those + arity_ok stg_arity + | isExternalName (idName bndr) = id_arity == stg_arity + | otherwise = True + id_arity = idArity bndr + mk_arity_msg stg_arity + = vcat [ppr bndr, + ptext (sLit "Id arity:") <+> ppr id_arity, + ptext (sLit "STG arity:") <+> ppr stg_arity] + +mkTopStgRhs :: Bool -> FreeVarsInfo + -> SRT -> StgBinderInfo -> StgExpr + -> StgRhs mkTopStgRhs is_static rhs_fvs srt binder_info (StgLam _ bndrs body) = ASSERT( is_static ) @@ -247,7 +272,7 @@ mkTopStgRhs is_static rhs_fvs srt binder_info (StgLam _ bndrs body) ReEntrant srt bndrs body - + mkTopStgRhs is_static _ _ _ (StgConApp con args) | is_static -- StgConApps can be updatable (see isCrossDllConApp) = StgRhsCon noCCS con args @@ -499,7 +524,7 @@ coreToStgApp _ f args = do -- two regardless. res_ty = exprType (mkApps (Var f) args) - app = case globalIdDetails f of + app = case idDetails f of DataConWorkId dc | saturated -> StgConApp dc args' PrimOpId op -> ASSERT( saturated ) StgOpApp (StgPrimOp op) args' res_ty @@ -1082,9 +1107,16 @@ myCollectArgs expr go (Note (SCC _) _) _ = pprPanic "CoreToStg.myCollectArgs" (ppr expr) go (Cast e _) as = go e as go (Note _ e) as = go e as + go (Lam b e) as + | isTyVar b = go e as -- Note [Collect args] go _ _ = pprPanic "CoreToStg.myCollectArgs" (ppr expr) \end{code} +Note [Collect args] +~~~~~~~~~~~~~~~~~~~ +This big-lambda case occurred following a rather obscure eta expansion. +It all seems a bit yukky to me. + \begin{code} stgArity :: Id -> HowBound -> Arity stgArity _ (LetBound _ arity) = arity