X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FstgSyn%2FCoreToStg.lhs;h=edda60300710a82d4de874124aa8740199820f42;hp=f7347ae83c5eaa18302326901000b8db5c613ee7;hb=6e9c0431a7cf2bf1a48f01db48c6a1d41fe15a09;hpb=6084fb5517da34f65034370a3695e2af3b85ce2b diff --git a/compiler/stgSyn/CoreToStg.lhs b/compiler/stgSyn/CoreToStg.lhs index f7347ae..edda603 100644 --- a/compiler/stgSyn/CoreToStg.lhs +++ b/compiler/stgSyn/CoreToStg.lhs @@ -12,7 +12,8 @@ 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 @@ -33,6 +34,8 @@ import Outputable import MonadUtils import FastString import Util +import ForeignCall +import PrimOp ( PrimCall(..) ) \end{code} %************************************************************************ @@ -156,11 +159,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 +184,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 +204,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 +232,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 +274,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 @@ -410,7 +437,7 @@ mkStgAltType bndr alts | isUnLiftedTyCon tc -> PrimAlt tc | isHiBootTyCon tc -> look_for_better_tycon | isAlgTyCon tc -> AlgAlt tc - | otherwise -> ASSERT( _is_poly_alt_tycon tc ) + | otherwise -> ASSERT2( _is_poly_alt_tycon tc, ppr tc ) PolyAlt Nothing -> PolyAlt @@ -499,12 +526,22 @@ 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' + + -- Some primitive operator that might be implemented as a library call. PrimOpId op -> ASSERT( saturated ) StgOpApp (StgPrimOp op) args' res_ty + + -- A call to some primitive Cmm function. + FCallId (CCall (CCallSpec (StaticTarget lbl (Just pkgId)) PrimCallConv _)) + -> ASSERT( saturated ) + StgOpApp (StgPrimCallOp (PrimCall lbl pkgId)) args' res_ty + + -- A regular foreign call. FCallId call -> ASSERT( saturated ) StgOpApp (StgFCallOp call (idUnique f)) args' res_ty + TickBoxOpId {} -> pprPanic "coreToStg TickBox" $ ppr (f,args') _other -> StgApp f args' @@ -1082,9 +1119,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