X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=ghc%2Fcompiler%2FstgSyn%2FCoreToStg.lhs;h=ec7c953ecb6c8f38c29af4ddf27e9a4b55047883;hb=508aae27ab8e5b4a3c518bdeeec4be5dbd540a4a;hp=07054ff6472fcfd006bfd8b1362b223375be67c8;hpb=10cbc75d37064b3ef76ca3ccd219d66e445ecb0f;p=ghc-hetmet.git diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs index 07054ff..ec7c953 100644 --- a/ghc/compiler/stgSyn/CoreToStg.lhs +++ b/ghc/compiler/stgSyn/CoreToStg.lhs @@ -19,7 +19,7 @@ import Type import TyCon ( isAlgTyCon ) import Literal import Id -import Var ( Var, globalIdDetails ) +import Var ( Var, globalIdDetails, varType ) import IdInfo import DataCon import CostCentre ( noCCS ) @@ -27,11 +27,10 @@ import VarSet import VarEnv import DataCon ( dataConWrapId ) import IdInfo ( OccInfo(..) ) -import TysPrim ( foreignObjPrimTyCon ) import Maybes ( maybeToBool ) import Name ( getOccName, isExternallyVisibleName, isDllName ) import OccName ( occNameUserString ) -import BasicTypes ( TopLevelFlag(..), isNotTopLevel ) +import BasicTypes ( TopLevelFlag(..), isNotTopLevel, Arity ) import CmdLineOpts ( DynFlags, opt_KeepStgTypes ) import FastTypes hiding ( fastOr ) import Outputable @@ -127,7 +126,7 @@ pairs. coreToStg :: DynFlags -> [CoreBind] -> IO [StgBinding] coreToStg dflags pgm = return pgm' - where (env', fvs, pgm') = coreTopBindsToStg emptyVarEnv pgm + where (_, _, pgm') = coreTopBindsToStg emptyVarEnv pgm coreExprToStg :: CoreExpr -> StgExpr coreExprToStg expr @@ -141,7 +140,7 @@ coreTopBindsToStg coreTopBindsToStg env [] = (env, emptyFVInfo, []) coreTopBindsToStg env (b:bs) - = (env2, fvs1, b':bs') + = (env2, fvs2, b':bs') where -- env accumulates down the list of binds, fvs accumulates upwards (env1, fvs2, b' ) = coreTopBindToStg env fvs1 b @@ -158,7 +157,7 @@ coreTopBindToStg env body_fvs (NonRec id rhs) = let caf_info = hasCafRefs env rhs - env' = extendVarEnv env id (LetBound how_bound emptyVarSet) + env' = extendVarEnv env id (LetBound how_bound emptyLVS (predictArity rhs)) how_bound | mayHaveCafRefs caf_info = TopLevelHasCafs | otherwise = TopLevelNoCafs @@ -173,6 +172,7 @@ coreTopBindToStg env body_fvs (NonRec id rhs) bind = StgNonRec (SRTEntries cafs) id stg_rhs in + ASSERT2(predictArity rhs == stgRhsArity stg_rhs, ppr id) ASSERT2(consistent caf_info bind, ppr id) -- WARN(not (consistent caf_info bind), ppr id <+> ppr cafs <+> ppCafInfo caf_info) (env', fvs' `unionFVInfo` body_fvs, bind) @@ -184,12 +184,14 @@ coreTopBindToStg env body_fvs (Rec pairs) -- to calculate caf_info, we initially map all the binders to -- TopLevelNoCafs. env1 = extendVarEnvList env - [ (b, LetBound TopLevelNoCafs emptyVarSet) | b <- binders ] + [ (b, LetBound TopLevelNoCafs emptyLVS (error "no arity")) + | b <- binders ] caf_info = hasCafRefss env1{-NB: not env'-} rhss env' = extendVarEnvList env - [ (b, LetBound how_bound emptyVarSet) | b <- binders ] + [ (b, LetBound how_bound emptyLVS (predictArity rhs)) + | (b,rhs) <- pairs ] how_bound | mayHaveCafRefs caf_info = TopLevelHasCafs | otherwise = TopLevelNoCafs @@ -205,6 +207,7 @@ coreTopBindToStg env body_fvs (Rec pairs) bind = StgRec (SRTEntries cafs) (zip binders stg_rhss) in + ASSERT2(and [predictArity rhs == stgRhsArity stg_rhs | (rhs,stg_rhs) <- rhss `zip` stg_rhss], ppr binders) ASSERT2(consistent caf_info bind, ppr binders) -- WARN(not (consistent caf_info bind), ppr binders <+> ppr cafs <+> ppCafInfo caf_info) (env', fvs' `unionFVInfo` body_fvs, bind) @@ -227,9 +230,6 @@ coreToStgRhs scope_fv_info top (binder, rhs) where binder_info = lookupFVInfo scope_fv_info binder -bogus_rhs = StgRhsClosure noCCS noBinderInfo [] ReEntrant [] bogus_expr -bogus_expr = (StgLit (MachInt 1)) - mkStgRhs :: TopLevelFlag -> FreeVarsInfo -> StgBinderInfo -> StgExpr -> StgRhs @@ -467,20 +467,6 @@ coreToStgExpr (Let bind body) returnLne (new_let, fvs, escs) \end{code} -If we've got a case containing a _ccall_GC_ primop, we need to -ensure that the arguments are kept live for the duration of the -call. This only an issue - -\begin{code} -isForeignObjArg :: Id -> Bool -isForeignObjArg x = isId x && isForeignObjPrimTy (idType x) - -isForeignObjPrimTy ty - = case splitTyConApp_maybe ty of - Just (tycon, _) -> tycon == foreignObjPrimTyCon - Nothing -> False -\end{code} - \begin{code} mkStgAlgAlts ty alts deflt = case alts of @@ -519,9 +505,16 @@ coreToStgApp maybe_thunk_body f args lookupVarLne f `thenLne` \ how_bound -> let - n_args = length args + n_val_args = valArgCount args not_letrec_bound = not (isLetBound how_bound) - fun_fvs = singletonFVInfo f how_bound fun_occ + fun_fvs + = let fvs = singletonFVInfo f how_bound fun_occ in + -- 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_KeepStgTypes then + fvs `unionFVInfo` tyvarFVInfo (tyVarsOfType (varType 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 @@ -529,18 +522,18 @@ coreToStgApp maybe_thunk_body f args -- let f = \ab -> e in f -- No point in having correct arity info for f! -- Hence the hasArity stuff below. - f_arity_info = idArityInfo f - f_arity = arityLowerBound f_arity_info -- Zero if no info + f_arity = case how_bound of + LetBound _ _ arity -> arity + _ -> 0 fun_occ - | not_letrec_bound = noBinderInfo -- Uninteresting variable - | f_arity > 0 && f_arity <= n_args = stgSatOcc -- Saturated or over-saturated function call - | otherwise = stgUnsatOcc -- Unsaturated function or thunk + | not_letrec_bound = noBinderInfo -- Uninteresting variable + | f_arity > 0 && f_arity <= n_val_args = stgSatOcc -- Saturated or over-saturated function call + | otherwise = stgUnsatOcc -- Unsaturated function or thunk fun_escs - | not_letrec_bound = emptyVarSet -- Only letrec-bound escapees are interesting - | hasArity f_arity_info && - f_arity == n_args = emptyVarSet -- A function *or thunk* with an exactly + | not_letrec_bound = emptyVarSet -- Only letrec-bound escapees are interesting + | f_arity == n_val_args = emptyVarSet -- A function *or thunk* with an exactly -- saturated call doesn't escape -- (let-no-escape applies to 'thunks' too) @@ -557,9 +550,11 @@ coreToStgApp maybe_thunk_body f args -- continuation, but it does no harm to just union the -- two regardless. + res_ty = exprType (mkApps (Var f) args) app = case globalIdDetails f of - DataConId dc -> StgConApp dc args' - PrimOpId op -> StgPrimApp op args' (exprType (mkApps (Var f) args)) + DataConId dc -> StgConApp dc args' + PrimOpId op -> StgOpApp (StgPrimOp op) args' res_ty + FCallId call -> StgOpApp (StgFCallOp call (idUnique f)) args' res_ty _other -> StgApp f args' in @@ -618,27 +613,28 @@ coreToStgLet -- is among the escaping vars coreToStgLet let_no_escape bind body - = fixLne (\ ~(_, _, _, _, _, rec_body_fvs, _, _) -> + = fixLne (\ ~(_, _, _, _, _, _, rec_body_fvs, _, _) -> -- Do the bindings, setting live_in_cont to empty if -- we ain't in a let-no-escape world getVarsLiveInCont `thenLne` \ live_in_cont -> setVarsLiveInCont (if let_no_escape then live_in_cont - else (emptyVarSet,emptyVarSet)) + else emptyLVS) (vars_bind rec_body_fvs bind) - `thenLne` \ (bind2, bind_fvs, bind_escs, bind_lvs, env_ext) -> + `thenLne` \ ( bind2, bind_fvs, bind_escs + , bind_lvs, bind_cafs, env_ext) -> -- Do the body extendVarEnvLne env_ext ( coreToStgExpr body `thenLne` \(body2, body_fvs, body_escs) -> freeVarsToLiveVars body_fvs `thenLne` \(body_lvs, _) -> - returnLne (bind2, bind_fvs, bind_escs, bind_lvs, + returnLne (bind2, bind_fvs, bind_escs, bind_lvs, bind_cafs, body2, body_fvs, body_escs, body_lvs) ) - ) `thenLne` (\ (bind2, bind_fvs, bind_escs, bind_lvs, + ) `thenLne` (\ (bind2, bind_fvs, bind_escs, bind_lvs, bind_cafs, body2, body_fvs, body_escs, body_lvs) -> @@ -692,15 +688,15 @@ coreToStgLet let_no_escape bind body NonRec binder rhs -> [binder] Rec pairs -> map fst pairs - mk_binding bind_lvs binder + mk_binding bind_lvs bind_cafs binder rhs = (binder, LetBound NotTopLevelBound -- Not top level - live_vars + live_vars (predictArity rhs) ) where live_vars = if let_no_escape then - extendVarSet bind_lvs binder + (extendVarSet bind_lvs binder, bind_cafs) else - unitVarSet binder + (unitVarSet binder, emptyVarSet) vars_bind :: FreeVarsInfo -- Free var info for body of binding -> CoreBind @@ -708,6 +704,7 @@ coreToStgLet let_no_escape bind body FreeVarsInfo, EscVarsSet, -- free vars; escapee vars StgLiveVars, -- vars live in binding + IdSet, -- CAFs live in binding [(Id, HowBound)]) -- extension to environment @@ -717,18 +714,19 @@ coreToStgLet let_no_escape bind body freeVarsToLiveVars bind_fvs `thenLne` \ (bind_lvs, bind_cafs) -> let - env_ext_item@(binder', _) = mk_binding bind_lvs binder + env_ext_item = mk_binding bind_lvs bind_cafs binder rhs in - returnLne (StgNonRec (SRTEntries bind_cafs) binder' rhs2, - bind_fvs, escs, bind_lvs, [env_ext_item]) + returnLne (StgNonRec (SRTEntries bind_cafs) binder rhs2, + bind_fvs, escs, bind_lvs, bind_cafs, [env_ext_item]) vars_bind body_fvs (Rec pairs) - = fixLne (\ ~(_, rec_rhs_fvs, _, bind_lvs, _) -> + = fixLne (\ ~(_, rec_rhs_fvs, _, bind_lvs, bind_cafs, _) -> let rec_scope_fvs = unionFVInfo body_fvs rec_rhs_fvs binders = map fst pairs - env_ext = map (mk_binding bind_lvs) binders + env_ext = [ mk_binding bind_lvs bind_cafs b rhs + | (b,rhs) <- pairs ] in extendVarEnvLne env_ext ( mapAndUnzip3Lne (coreToStgRhs rec_scope_fvs NotTopLevel) pairs @@ -739,8 +737,9 @@ coreToStgLet let_no_escape bind body in freeVarsToLiveVars (binders `minusFVBinders` bind_fvs) `thenLne` \ (bind_lvs, bind_cafs) -> + returnLne (StgRec (SRTEntries bind_cafs) (binders `zip` rhss2), - bind_fvs, escs, bind_lvs, env_ext) + bind_fvs, escs, bind_lvs, bind_cafs, env_ext) ) ) @@ -752,6 +751,29 @@ is_join_var j = occNameUserString (getOccName j) == "$j" %************************************************************************ %* * +\subsection{Arity prediction} +%* * +%************************************************************************ + +To avoid yet another knot, we predict the arity of each function from +its Core form, based on the number of visible top-level lambdas. +It should be the same as the arity of the STG RHS! + +\begin{code} +predictArity :: CoreExpr -> Int +predictArity (Lam x e) + | isTyVar x = predictArity e + | otherwise = 1 + predictArity e +predictArity (Note _ e) + -- Ignore coercions. Top level sccs are removed by the final + -- profiling pass, so we ignore those too. + = predictArity e +predictArity _ = 0 +\end{code} + + +%************************************************************************ +%* * \subsection[LNE-monad]{A little monad for this let-no-escaping pass} %* * %************************************************************************ @@ -771,10 +793,11 @@ data HowBound | LambdaBound | LetBound TopLevelCafInfo - StgLiveVars -- Live vars... see notes below + (StgLiveVars, IdSet) -- (Live vars, Live CAFs)... see notes below + Arity -- its arity (local Ids don't have arity info at this point) -isLetBound (LetBound _ _) = True -isLetBound other = False +isLetBound (LetBound _ _ _) = True +isLetBound other = False \end{code} For a let(rec)-bound variable, x, we record StgLiveVars, the set of @@ -791,7 +814,9 @@ variables in it. The std monad functions: \begin{code} initLne :: IdEnv HowBound -> LneM a -> a -initLne env m = m env (emptyVarSet,emptyVarSet) +initLne env m = m env emptyLVS + +emptyLVS = (emptyVarSet,emptyVarSet) {-# INLINE thenLne #-} {-# INLINE returnLne #-} @@ -861,30 +886,31 @@ lookupVarLne v env lvs_cont freeVarsToLiveVars :: FreeVarsInfo -> LneM (StgLiveVars, IdSet) freeVarsToLiveVars fvs env live_in_cont - = returnLne (lvs `unionVarSet` lvs_cont, - mkVarSet cafs `unionVarSet` cafs_cont) - env live_in_cont + = returnLne (lvs, cafs) env live_in_cont where (lvs_cont, cafs_cont) = live_in_cont -- not a strict pattern match! - (local, global) = partition isLocalId (allFVs fvs) + (local, global) = partition isLocalId (allFreeIds fvs) + + (lvs_from_fvs, caf_extras) = unzip (map do_one local) + + lvs = unionVarSets lvs_from_fvs + `unionVarSet` lvs_cont - cafs = filter is_caf_one global - lvs = unionVarSets (map do_one local) + cafs = mkVarSet (filter is_caf_one global) + `unionVarSet` (unionVarSets caf_extras) + `unionVarSet` cafs_cont do_one v - = if isLocalId v then - case (lookupVarEnv env v) of - Just (LetBound _ lvs) -> extendVarSet lvs v - Just _ -> unitVarSet v + = case (lookupVarEnv env v) of + Just (LetBound _ (lvs,cafs) _) -> (extendVarSet lvs v, cafs) + Just _ -> (unitVarSet v, emptyVarSet) Nothing -> pprPanic "lookupLiveVarsForSet/do_one:" (ppr v) - else - emptyVarSet is_caf_one v - = case lookupVarEnv env v of - Just (LetBound TopLevelHasCafs lvs) -> + = case lookupVarEnv env v of + Just (LetBound TopLevelHasCafs (lvs,_) _) -> ASSERT( isEmptyVarSet lvs ) True - Just (LetBound _ _) -> False + Just (LetBound _ _ _) -> False _otherwise -> mayHaveCafRefs (idCafInfo v) \end{code} @@ -924,7 +950,7 @@ singletonFVInfo :: Id -> HowBound -> StgBinderInfo -> FreeVarsInfo singletonFVInfo id ImportBound info | mayHaveCafRefs (idCafInfo id) = unitVarEnv id (id, TopLevelHasCafs, info) | otherwise = emptyVarEnv -singletonFVInfo id (LetBound top_level _) info +singletonFVInfo id (LetBound top_level _ _) info = unitVarEnv id (id, top_level, info) singletonFVInfo id other info = unitVarEnv id (id, NotTopLevelBound, info) @@ -963,13 +989,15 @@ lookupFVInfo fvs id Nothing -> noBinderInfo Just (_,_,info) -> info -allFVs :: FreeVarsInfo -> [Id] -- Non-top-level things only -allFVs fvs = [id | (id,_,_) <- rngVarEnv fvs] +allFreeIds :: FreeVarsInfo -> [Id] -- Non-top-level things only +allFreeIds fvs = [id | (id,_,_) <- rngVarEnv fvs, isId id] -getFVs :: FreeVarsInfo -> [Id] -- Non-top-level things only +-- Non-top-level things only, both type variables and ids (type variables +-- only if opt_KeepStgTypes. +getFVs :: FreeVarsInfo -> [Var] getFVs fvs = [id | (id,NotTopLevelBound,_) <- rngVarEnv fvs] -getFVSet :: FreeVarsInfo -> IdSet +getFVSet :: FreeVarsInfo -> VarSet getFVSet fvs = mkVarSet (getFVs fvs) plusFVInfo (id1,top1,info1) (id2,top2,info2) @@ -1055,8 +1083,8 @@ cafRefs p (Var id) | isLocalId id = fastBool False | otherwise = case lookupVarEnv p id of - Just (LetBound TopLevelHasCafs _) -> fastBool True - Just (LetBound _ _) -> fastBool False + Just (LetBound TopLevelHasCafs _ _) -> fastBool True + Just (LetBound _ _ _) -> fastBool False Nothing -> fastBool (cgMayHaveCafRefs (idCgInfo id)) -- imported Ids cafRefs p (Lit l) = fastBool False @@ -1090,7 +1118,12 @@ rhsIsNonUpd :: CoreExpr -> Bool -- -- c) don't look through unfolding of f in (f x). I'm suspicious of this one -rhsIsNonUpd (Lam b e) = isId b || rhsIsNonUpd e +-- This function has to line up with what the update flag +-- for the StgRhs gets set to in mkStgRhs (above) +-- +-- When opt_KeepStgTypes is on, we keep type lambdas and treat +-- them as making the RHS re-entrant (non-updatable). +rhsIsNonUpd (Lam b e) = isRuntimeVar b || rhsIsNonUpd e rhsIsNonUpd (Note (SCC _) e) = False rhsIsNonUpd (Note _ e) = rhsIsNonUpd e rhsIsNonUpd other_expr @@ -1109,11 +1142,11 @@ rhsIsNonUpd other_expr idAppIsNonUpd :: Id -> Int -> [CoreExpr] -> Bool idAppIsNonUpd id n_val_args args - | Just con <- isDataConId_maybe id = not (isDynConApp con args) + | Just con <- isDataConId_maybe id = not (isCrossDllConApp con args) | otherwise = n_val_args < idArity id -isDynConApp :: DataCon -> [CoreExpr] -> Bool -isDynConApp con args = isDllName (dataConName con) || any isDynArg args +isCrossDllConApp :: DataCon -> [CoreExpr] -> Bool +isCrossDllConApp con args = isDllName (dataConName con) || any isCrossDllArg args -- Top-level constructor applications can usually be allocated -- statically, but they can't if -- a) the constructor, or any of the arguments, come from another DLL @@ -1124,10 +1157,12 @@ isDynConApp con args = isDllName (dataConName con) || any isDynArg args -- All this should match the decision in (see CoreToStg.coreToStgRhs) -isDynArg :: CoreExpr -> Bool -isDynArg (Var v) = isDllName (idName v) -isDynArg (Note _ e) = isDynArg e -isDynArg (Lit lit) = isLitLitLit lit -isDynArg (App e _) = isDynArg e -- must be a type app -isDynArg (Lam _ e) = isDynArg e -- must be a type lam +isCrossDllArg :: CoreExpr -> Bool +-- True if somewhere in the expression there's a cross-DLL reference +isCrossDllArg (Type _) = False +isCrossDllArg (Var v) = isDllName (idName v) +isCrossDllArg (Note _ e) = isCrossDllArg e +isCrossDllArg (Lit lit) = isLitLitLit lit +isCrossDllArg (App e1 e2) = isCrossDllArg e1 || isCrossDllArg e2 -- must be a type app +isCrossDllArg (Lam v e) = isCrossDllArg e -- must be a type lam \end{code}