X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FstgSyn%2FCoreToStg.lhs;h=b2d725796d1250eeec37179d62e72b849f91c966;hp=4956ccc8b0d4d3ca8bd0408f6fed97232ac78387;hb=cbbee4e8727c583daf32d9bf17f00afaa839ef10;hpb=3dcb2a668e541eb0b04b5d22c2b86b2700766d46 diff --git a/compiler/stgSyn/CoreToStg.lhs b/compiler/stgSyn/CoreToStg.lhs index 4956ccc..b2d7257 100644 --- a/compiler/stgSyn/CoreToStg.lhs +++ b/compiler/stgSyn/CoreToStg.lhs @@ -7,25 +7,19 @@ And, as we have the info in hand, we may convert some lets to let-no-escapes. \begin{code} -{-# OPTIONS -w #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and fix --- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings --- for details - 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 ) @@ -35,12 +29,13 @@ import Maybes ( maybeToBool ) import Name ( getOccName, isExternalName, nameOccName ) import OccName ( occNameString, occNameFS ) import BasicTypes ( Arity ) -import StaticFlags ( opt_RuntimeTypes ) import Module import Outputable import MonadUtils import FastString import Util +import ForeignCall +import PrimOp ( PrimCall(..) ) \end{code} %************************************************************************ @@ -160,15 +155,16 @@ coreTopBindsToStg -> [CoreBind] -> (IdEnv HowBound, FreeVarsInfo, [StgBinding]) -coreTopBindsToStg this_pkg env [] = (env, emptyFVInfo, []) +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 @@ -188,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 ] @@ -209,16 +204,17 @@ 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 -- floated out a binding, in which case it will be approximate. +consistentCafInfo :: Id -> GenStgBinding Var Id -> Bool consistentCafInfo id bind - | occNameFS (nameOccName (idName id)) == FSLIT("sat") + | occNameFS (nameOccName (idName id)) == fsLit "sat" = safe | otherwise = WARN (not exact, ppr id) safe @@ -236,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 ) @@ -254,8 +274,8 @@ mkTopStgRhs is_static rhs_fvs srt binder_info (StgLam _ bndrs body) ReEntrant srt bndrs body - -mkTopStgRhs is_static rhs_fvs srt binder_info (StgConApp con args) + +mkTopStgRhs is_static _ _ _ (StgConApp con args) | is_static -- StgConApps can be updatable (see isCrossDllConApp) = StgRhsCon noCCS con args @@ -319,15 +339,15 @@ coreToStgExpr (Note (SCC cc) expr) = do (expr2, fvs, escs) <- coreToStgExpr expr return (StgSCC cc expr2, fvs, escs) -coreToStgExpr (Case (Var id) _bndr ty [(DEFAULT,[],expr)]) +coreToStgExpr (Case (Var id) _bndr _ty [(DEFAULT,[],expr)]) | Just (TickBox m n) <- isTickBoxOp_maybe id = do (expr2, fvs, escs) <- coreToStgExpr expr return (StgTick m n expr2, fvs, escs) -coreToStgExpr (Note other_note expr) +coreToStgExpr (Note _ expr) = coreToStgExpr expr -coreToStgExpr (Cast expr co) +coreToStgExpr (Cast expr _) = coreToStgExpr expr -- Cases require a little more real work. @@ -356,7 +376,7 @@ coreToStgExpr (Case scrut bndr _ alts) = do -- We tell the scrutinee that everything -- live in the alts is live in it, too. - (scrut2, scrut_fvs, scrut_escs, scrut_lv_info) + (scrut2, scrut_fvs, _scrut_escs, scrut_lv_info) <- setVarsLiveInCont alts_lv_info $ do (scrut2, scrut_fvs, scrut_escs) <- coreToStgExpr scrut scrut_lv_info <- freeVarsToLiveVars scrut_fvs @@ -405,9 +425,12 @@ coreToStgExpr (Let bind body) = do ) return (new_let, fvs, escs) + +coreToStgExpr e = pprPanic "coreToStgExpr" (ppr e) \end{code} \begin{code} +mkStgAltType :: Id -> [CoreAlt] -> AltType mkStgAltType bndr alts = case splitTyConApp_maybe (repType (idType bndr)) of Just (tc,_) | isUnboxedTupleTyCon tc -> UbxTupAlt tc @@ -456,21 +479,17 @@ coreToStgApp -> LneM (StgExpr, FreeVarsInfo, EscVarsSet) -coreToStgApp maybe_thunk_body f args = do +coreToStgApp _ f args = do (args', args_fvs) <- coreToStgArgs args how_bound <- lookupVarLne f let n_val_args = valArgCount args not_letrec_bound = not (isLetBound how_bound) - fun_fvs - = let fvs = singletonFVInfo f how_bound fun_occ in + fun_fvs = singletonFVInfo f how_bound fun_occ -- e.g. (f :: a -> int) (x :: a) -- 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 (idType f)) - else fvs -- Mostly, the arity info of a function is in the fn's IdInfo -- But new bindings introduced by CoreSat may not have no @@ -507,10 +526,15 @@ coreToStgApp maybe_thunk_body 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 + FCallId (CCall (CCallSpec (StaticTarget lbl) PrimCallConv _)) + -- prim calls are represented as FCalls in core, + -- but in stg we distinguish them + -> ASSERT( saturated ) + StgOpApp (StgPrimCallOp (PrimCall lbl)) args' res_ty FCallId call -> ASSERT( saturated ) StgOpApp (StgFCallOp call (idUnique f)) args' res_ty TickBoxOpId {} -> pprPanic "coreToStg TickBox" $ ppr (f,args') @@ -535,16 +559,13 @@ coreToStgArgs :: [CoreArg] -> LneM ([StgArg], FreeVarsInfo) coreToStgArgs [] = return ([], emptyFVInfo) -coreToStgArgs (Type ty : args) = do -- Type argument +coreToStgArgs (Type _ : args) = do -- Type argument (args', fvs) <- coreToStgArgs args - if opt_RuntimeTypes then - return (StgTypeArg ty : args', fvs `unionFVInfo` tyvarFVInfo (tyVarsOfType ty)) - else - return (args', fvs) + return (args', fvs) coreToStgArgs (arg : args) = do -- Non-type argument (stg_args, args_fvs) <- coreToStgArgs args - (arg', arg_fvs, escs) <- coreToStgExpr arg + (arg', arg_fvs, _escs) <- coreToStgExpr arg let fvs = args_fvs `unionFVInfo` arg_fvs stg_arg = case arg' of @@ -573,7 +594,7 @@ coreToStgArgs (arg : args) = do -- Non-type argument -- we complain. -- We also want to check if a pointer is cast to a non-ptr etc - WARN( bad_args, ptext SLIT("Dangerous-looking argument. Probable cause: bad unsafeCoerce#") $$ ppr arg ) + WARN( bad_args, ptext (sLit "Dangerous-looking argument. Probable cause: bad unsafeCoerce#") $$ ppr arg ) return (stg_arg : stg_args, fvs) @@ -716,7 +737,6 @@ coreToStgRhs :: FreeVarsInfo -- Free var info for the scope of the binding coreToStgRhs scope_fv_info binders (bndr, rhs) = do (new_rhs, rhs_fvs, rhs_escs) <- coreToStgExpr rhs - env <- getEnvLne lv_info <- freeVarsToLiveVars (binders `minusFVBinders` rhs_fvs) return (mkStgRhs rhs_fvs (mkSRT lv_info) bndr_info new_rhs, rhs_fvs, lv_info, rhs_escs) @@ -725,8 +745,7 @@ coreToStgRhs scope_fv_info binders (bndr, rhs) = do mkStgRhs :: FreeVarsInfo -> SRT -> StgBinderInfo -> StgExpr -> StgRhs -mkStgRhs rhs_fvs srt binder_info (StgConApp con args) - = StgRhsCon noCCS con args +mkStgRhs _ _ _ (StgConApp con args) = StgRhsCon noCCS con args mkStgRhs rhs_fvs srt binder_info (StgLam _ bndrs body) = StgRhsClosure noCCS binder_info @@ -835,12 +854,14 @@ data LetInfo -- itself is always a member of -- the dynamic set of its own LiveInfo +isLetBound :: HowBound -> Bool isLetBound (LetBound _ _) = True -isLetBound other = False +isLetBound _ = False -topLevelBound ImportBound = True +topLevelBound :: HowBound -> Bool +topLevelBound ImportBound = True topLevelBound (LetBound TopLet _) = True -topLevelBound other = False +topLevelBound _ = False \end{code} For a let(rec)-bound variable, x, we record LiveInfo, the set of @@ -892,7 +913,7 @@ initLne env m = unLneM m env emptyLiveInfo {-# INLINE returnLne #-} returnLne :: a -> LneM a -returnLne e = LneM $ \env lvs_cont -> e +returnLne e = LneM $ \_ _ -> e thenLne :: LneM a -> (a -> LneM b) -> LneM b thenLne m k = LneM $ \env lvs_cont @@ -912,11 +933,11 @@ Functions specific to this monad: \begin{code} getVarsLiveInCont :: LneM LiveInfo -getVarsLiveInCont = LneM $ \env lvs_cont -> lvs_cont +getVarsLiveInCont = LneM $ \_env lvs_cont -> lvs_cont setVarsLiveInCont :: LiveInfo -> LneM a -> LneM a setVarsLiveInCont new_lvs_cont expr - = LneM $ \env lvs_cont + = LneM $ \env _lvs_cont -> unLneM expr env new_lvs_cont extendVarEnvLne :: [(Id, HowBound)] -> LneM a -> LneM a @@ -925,10 +946,7 @@ extendVarEnvLne ids_w_howbound expr -> unLneM expr (extendVarEnvList env ids_w_howbound) lvs_cont lookupVarLne :: Id -> LneM HowBound -lookupVarLne v = LneM $ \env lvs_cont -> lookupBinding env v - -getEnvLne :: LneM (IdEnv HowBound) -getEnvLne = LneM $ \env lvs_cont -> env +lookupVarLne v = LneM $ \env _lvs_cont -> lookupBinding env v lookupBinding :: IdEnv HowBound -> Id -> HowBound lookupBinding env v = case lookupVarEnv env v of @@ -943,7 +961,7 @@ lookupBinding env v = case lookupVarEnv env v of freeVarsToLiveVars :: FreeVarsInfo -> LneM LiveInfo freeVarsToLiveVars fvs = LneM freeVarsToLiveVars' where - freeVarsToLiveVars' env live_in_cont = live_info + freeVarsToLiveVars' _env live_in_cont = live_info where live_info = foldr unionLiveInfo live_in_cont lvs_from_fvs lvs_from_fvs = map do_one (allFreeIds fvs) @@ -1007,12 +1025,6 @@ singletonFVInfo id ImportBound info | otherwise = emptyVarEnv singletonFVInfo id how_bound info = unitVarEnv id (id, how_bound, info) -tyvarFVInfo :: TyVarSet -> FreeVarsInfo -tyvarFVInfo tvs = foldVarSet add emptyFVInfo tvs - where - add tv fvs = extendVarEnv fvs tv (tv, LambdaBound, noBinderInfo) - -- Type variables must be lambda-bound - unionFVInfo :: FreeVarsInfo -> FreeVarsInfo -> FreeVarsInfo unionFVInfo fv1 fv2 = plusVarEnv_C plusFVInfo fv1 fv2 @@ -1023,10 +1035,7 @@ minusFVBinders :: [Id] -> FreeVarsInfo -> FreeVarsInfo minusFVBinders vs fv = foldr minusFVBinder fv vs minusFVBinder :: Id -> FreeVarsInfo -> FreeVarsInfo -minusFVBinder v fv | isId v && opt_RuntimeTypes - = (fv `delVarEnv` v) `unionFVInfo` - tyvarFVInfo (tyVarsOfType (idType v)) - | otherwise = fv `delVarEnv` v +minusFVBinder v fv = fv `delVarEnv` v -- When removing a binder, remember to add its type variables -- c.f. CoreFVs.delBinderFV @@ -1043,10 +1052,11 @@ 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,_) <- varEnvElts fvs, isId id] +allFreeIds fvs = ASSERT( all (isId . fst) ids ) ids + where + ids = [(id,how_bound) | (id,how_bound,_) <- varEnvElts fvs] -- 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, _) <- varEnvElts fvs, not (topLevelBound how_bound) ] @@ -1054,38 +1064,42 @@ getFVs fvs = [id | (id, how_bound, _) <- varEnvElts fvs, getFVSet :: FreeVarsInfo -> VarSet getFVSet fvs = mkVarSet (getFVs fvs) +plusFVInfo :: (Var, HowBound, StgBinderInfo) + -> (Var, HowBound, StgBinderInfo) + -> (Var, HowBound, StgBinderInfo) plusFVInfo (id1,hb1,info1) (id2,hb2,info2) = ASSERT (id1 == id2 && hb1 `check_eq_how_bound` hb2) (id1, hb1, combineStgBinderInfo info1 info2) -- The HowBound info for a variable in the FVInfo should be consistent +check_eq_how_bound :: HowBound -> HowBound -> Bool check_eq_how_bound ImportBound ImportBound = True check_eq_how_bound LambdaBound LambdaBound = True check_eq_how_bound (LetBound li1 ar1) (LetBound li2 ar2) = ar1 == ar2 && check_eq_li li1 li2 -check_eq_how_bound hb1 hb2 = False +check_eq_how_bound _ _ = False +check_eq_li :: LetInfo -> LetInfo -> Bool check_eq_li (NestedLet _) (NestedLet _) = True check_eq_li TopLet TopLet = True -check_eq_li li1 li2 = False +check_eq_li _ _ = False \end{code} Misc. \begin{code} filterStgBinders :: [Var] -> [Var] -filterStgBinders bndrs - | opt_RuntimeTypes = bndrs - | otherwise = filter isId bndrs +filterStgBinders bndrs = filter isId bndrs \end{code} \begin{code} -- Ignore all notes except SCC +myCollectBinders :: Expr Var -> ([Var], Expr Var) myCollectBinders expr = go [] expr where go bs (Lam b e) = go (b:bs) e go bs e@(Note (SCC _) _) = (reverse bs, e) - go bs (Cast e co) = go bs e + go bs (Cast e _) = go bs e go bs (Note _ e) = go bs e go bs e = (reverse bs, e) @@ -1097,15 +1111,22 @@ myCollectArgs expr where go (Var v) as = (v, as) go (App f a) as = go f (a:as) - go (Note (SCC _) e) as = pprPanic "CoreToStg.myCollectArgs" (ppr expr) - go (Cast e co) as = go e as - go (Note n e) as = go e as - go _ as = pprPanic "CoreToStg.myCollectArgs" (ppr 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 f (LetBound _ arity) = arity +stgArity _ (LetBound _ arity) = arity stgArity f ImportBound = idArity f -stgArity f LambdaBound = 0 +stgArity _ LambdaBound = 0 \end{code}