diff options
Diffstat (limited to 'compiler/stgSyn/CoreToStg.hs')
| -rw-r--r-- | compiler/stgSyn/CoreToStg.hs | 140 |
1 files changed, 37 insertions, 103 deletions
diff --git a/compiler/stgSyn/CoreToStg.hs b/compiler/stgSyn/CoreToStg.hs index 8275564448..12940753f9 100644 --- a/compiler/stgSyn/CoreToStg.hs +++ b/compiler/stgSyn/CoreToStg.hs @@ -118,19 +118,6 @@ import Control.Monad (liftM, ap) -- -- See also: Commentary/Rts/Storage/GC/CAFs on the GHC Wiki. --- Note [Collecting live CAF info] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- In this pass we also collect information on which CAFs are live. --- --- A top-level Id has CafInfo, which is --- --- - MayHaveCafRefs, if it may refer indirectly to --- one or more CAFs, or --- - NoCafRefs if it definitely doesn't --- --- The CafInfo has already been calculated during the CoreTidy pass. --- -- Note [What is a non-escaping let] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- @@ -282,7 +269,7 @@ coreTopBindToStg dflags this_mod env body_fvs ccs (NonRec id rhs) (stg_rhs, fvs', ccs') = initCts env $ - coreToTopStgRhs dflags ccs this_mod body_fvs (id,rhs) + coreToTopStgRhs dflags ccs this_mod (id,rhs) bind = StgTopLifted $ StgNonRec id stg_rhs in @@ -308,7 +295,7 @@ coreTopBindToStg dflags this_mod env body_fvs ccs (Rec pairs) = initCts env' $ do mapAccumLM (\(fvs, ccs) rhs -> do (rhs', fvs', ccs') <- - coreToTopStgRhs dflags ccs this_mod body_fvs rhs + coreToTopStgRhs dflags ccs this_mod rhs return ((fvs' `unionFVInfo` fvs, ccs'), rhs')) (body_fvs, ccs) pairs @@ -338,15 +325,14 @@ coreToTopStgRhs :: DynFlags -> CollectedCCs -> Module - -> FreeVarsInfo -- Free var info for the scope of the binding -> (Id,CoreExpr) -> CtsM (StgRhs, FreeVarsInfo, CollectedCCs) -coreToTopStgRhs dflags ccs this_mod scope_fv_info (bndr, rhs) +coreToTopStgRhs dflags ccs this_mod (bndr, rhs) = do { (new_rhs, rhs_fvs) <- coreToStgExpr rhs ; let (stg_rhs, ccs') = - mkTopStgRhs dflags this_mod ccs rhs_fvs bndr bndr_info new_rhs + mkTopStgRhs dflags this_mod ccs rhs_fvs bndr new_rhs stg_arity = stgRhsArity stg_rhs @@ -354,8 +340,6 @@ coreToTopStgRhs dflags ccs this_mod scope_fv_info (bndr, rhs) rhs_fvs, ccs') } where - bndr_info = lookupFVInfo scope_fv_info bndr - -- 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 @@ -558,8 +542,7 @@ coreToStgApp _ f args ticks = do let n_val_args = valArgCount args - not_letrec_bound = not (isLetBound how_bound) - fun_fvs = singletonFVInfo f how_bound fun_occ + fun_fvs = singletonFVInfo f how_bound -- 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 @@ -574,11 +557,6 @@ coreToStgApp _ f args ticks = do f_arity = stgArity f how_bound saturated = f_arity <= n_val_args - fun_occ - | not_letrec_bound = noBinderInfo -- Uninteresting variable - | f_arity > 0 && saturated = stgSatOcc -- Saturated or over-saturated function call - | otherwise = stgUnsatOcc -- Unsaturated function or thunk - res_ty = exprType (mkApps (Var f) args) app = case idDetails f of DataConWorkId dc @@ -612,8 +590,6 @@ coreToStgApp _ f args ticks = do fvs ) - - -- --------------------------------------------------------------------------- -- Argument lists -- This is the guy that turns applications into A-normal form @@ -686,10 +662,10 @@ coreToStgLet coreToStgLet bind body = do (bind2, bind_fvs, body2, body_fvs) - <- mfix $ \ ~(_, _, _, rec_body_fvs) -> do + <- do ( bind2, bind_fvs, env_ext) - <- vars_bind rec_body_fvs bind + <- vars_bind bind -- Do the body extendVarEnvCts env_ext $ do @@ -698,7 +674,6 @@ coreToStgLet bind body = do return (bind2, bind_fvs, body2, body_fvs) - -- Compute the new let-expression let new_let | isJoinBind bind = StgLetNoEscape bind2 body2 @@ -717,59 +692,51 @@ coreToStgLet bind body = do mk_binding binder rhs = (binder, LetBound NestedLet (manifestArity rhs)) - vars_bind :: FreeVarsInfo -- Free var info for body of binding - -> CoreBind + vars_bind :: CoreBind -> CtsM (StgBinding, FreeVarsInfo, [(Id, HowBound)]) -- extension to environment - - vars_bind body_fvs (NonRec binder rhs) = do - (rhs2, bind_fvs) <- coreToStgRhs body_fvs (binder,rhs) + vars_bind (NonRec binder rhs) = do + (rhs2, bind_fvs) <- coreToStgRhs (binder,rhs) let env_ext_item = mk_binding binder rhs return (StgNonRec binder rhs2, bind_fvs, [env_ext_item]) - - vars_bind body_fvs (Rec pairs) - = mfix $ \ ~(_, rec_rhs_fvs, _) -> - let - rec_scope_fvs = unionFVInfo body_fvs rec_rhs_fvs + vars_bind (Rec pairs) + = let binders = map fst pairs env_ext = [ mk_binding b rhs | (b,rhs) <- pairs ] in extendVarEnvCts env_ext $ do (rhss2, fvss) - <- mapAndUnzipM (coreToStgRhs rec_scope_fvs) pairs + <- mapAndUnzipM coreToStgRhs pairs let bind_fvs = unionFVInfos fvss return (StgRec (binders `zip` rhss2), bind_fvs, env_ext) -coreToStgRhs :: FreeVarsInfo -- Free var info for the scope of the binding - -> (Id,CoreExpr) +coreToStgRhs :: (Id,CoreExpr) -> CtsM (StgRhs, FreeVarsInfo) -coreToStgRhs scope_fv_info (bndr, rhs) = do +coreToStgRhs (bndr, rhs) = do (new_rhs, rhs_fvs) <- coreToStgExpr rhs - return (mkStgRhs rhs_fvs bndr bndr_info new_rhs, rhs_fvs) - where - bndr_info = lookupFVInfo scope_fv_info bndr + return (mkStgRhs rhs_fvs bndr new_rhs, rhs_fvs) -- Generate a top-level RHS. Any new cost centres generated for CAFs will be -- appended to `CollectedCCs` argument. mkTopStgRhs :: DynFlags -> Module -> CollectedCCs - -> FreeVarsInfo -> Id -> StgBinderInfo -> StgExpr + -> FreeVarsInfo -> Id -> StgExpr -> (StgRhs, CollectedCCs) -mkTopStgRhs dflags this_mod ccs rhs_fvs bndr binder_info rhs +mkTopStgRhs dflags this_mod ccs rhs_fvs bndr rhs | StgLam bndrs body <- rhs = -- StgLam can't have empty arguments, so not CAF - ( StgRhsClosure dontCareCCS binder_info + ( StgRhsClosure dontCareCCS (getFVs rhs_fvs) ReEntrant (toList bndrs) body @@ -785,13 +752,13 @@ mkTopStgRhs dflags this_mod ccs rhs_fvs bndr binder_info rhs -- Otherwise it's a CAF, see Note [Cost-centre initialization plan]. | gopt Opt_AutoSccsOnIndividualCafs dflags - = ( StgRhsClosure caf_ccs binder_info + = ( StgRhsClosure caf_ccs (getFVs rhs_fvs) upd_flag [] rhs , collectCC caf_cc caf_ccs ccs ) | otherwise - = ( StgRhsClosure all_cafs_ccs binder_info + = ( StgRhsClosure all_cafs_ccs (getFVs rhs_fvs) upd_flag [] rhs , ccs ) @@ -816,17 +783,17 @@ mkTopStgRhs dflags this_mod ccs rhs_fvs bndr binder_info rhs -- Generate a non-top-level RHS. Cost-centre is always currentCCS, -- see Note [Cost-centre initialzation plan]. -mkStgRhs :: FreeVarsInfo -> Id -> StgBinderInfo -> StgExpr -> StgRhs -mkStgRhs rhs_fvs bndr binder_info rhs +mkStgRhs :: FreeVarsInfo -> Id -> StgExpr -> StgRhs +mkStgRhs rhs_fvs bndr rhs | StgLam bndrs body <- rhs - = StgRhsClosure currentCCS binder_info + = StgRhsClosure currentCCS (getFVs rhs_fvs) ReEntrant (toList bndrs) body | isJoinId bndr -- must be a nullary join point = ASSERT(idJoinArity bndr == 0) - StgRhsClosure currentCCS binder_info + StgRhsClosure currentCCS (getFVs rhs_fvs) ReEntrant -- ignored for LNE [] rhs @@ -835,7 +802,7 @@ mkStgRhs rhs_fvs bndr binder_info rhs = StgRhsCon currentCCS con args | otherwise - = StgRhsClosure currentCCS binder_info + = StgRhsClosure currentCCS (getFVs rhs_fvs) upd_flag [] rhs where @@ -924,10 +891,6 @@ data LetInfo | NestedLet deriving (Eq) -isLetBound :: HowBound -> Bool -isLetBound (LetBound _ _) = True -isLetBound _ = False - topLevelBound :: HowBound -> Bool topLevelBound ImportBound = True topLevelBound (LetBound TopLet _) = True @@ -974,11 +937,6 @@ instance Applicative CtsM where instance Monad CtsM where (>>=) = thenCts -instance MonadFix CtsM where - mfix expr = CtsM $ \env -> - let result = unCtsM (expr result) env - in result - -- Functions specific to this monad: extendVarEnvCts :: [(Id, HowBound)] -> CtsM a -> CtsM a @@ -1007,7 +965,7 @@ getAllCAFsCC this_mod = -- Free variable information -- --------------------------------------------------------------------------- -type FreeVarsInfo = VarEnv (Var, HowBound, StgBinderInfo) +type FreeVarsInfo = VarEnv (Var, HowBound) -- The Var is so we can gather up the free variables -- as a set. -- @@ -1017,31 +975,16 @@ type FreeVarsInfo = VarEnv (Var, HowBound, StgBinderInfo) -- Imported Ids without CAF refs are simply -- not put in the FreeVarsInfo for an expression. -- See singletonFVInfo and freeVarsToLiveVars - -- - -- StgBinderInfo records how it occurs; notably, we - -- are interested in whether it only occurs in saturated - -- applications, because then we don't need to build a - -- curried version. - -- If f is mapped to noBinderInfo, that means - -- that f *is* mentioned (else it wouldn't be in the - -- IdEnv at all), but perhaps in an unsaturated applications. - -- - -- All case/lambda-bound things are also mapped to - -- noBinderInfo, since we aren't interested in their - -- occurrence info. - -- - -- For ILX we track free var info for type variables too; - -- hence VarEnv not IdEnv emptyFVInfo :: FreeVarsInfo emptyFVInfo = emptyVarEnv -singletonFVInfo :: Id -> HowBound -> StgBinderInfo -> FreeVarsInfo +singletonFVInfo :: Id -> HowBound -> FreeVarsInfo -- Don't record non-CAF imports at all, to keep free-var sets small -singletonFVInfo id ImportBound info - | mayHaveCafRefs (idCafInfo id) = unitVarEnv id (id, ImportBound, info) +singletonFVInfo id ImportBound + | mayHaveCafRefs (idCafInfo id) = unitVarEnv id (id, ImportBound) | otherwise = emptyVarEnv -singletonFVInfo id how_bound info = unitVarEnv id (id, how_bound, info) +singletonFVInfo id how_bound = unitVarEnv id (id, how_bound) unionFVInfo :: FreeVarsInfo -> FreeVarsInfo -> FreeVarsInfo unionFVInfo fv1 fv2 = plusVarEnv_C plusFVInfo fv1 fv2 @@ -1060,29 +1003,20 @@ minusFVBinder v fv = fv `delVarEnv` v elementOfFVInfo :: Id -> FreeVarsInfo -> Bool elementOfFVInfo id fvs = isJust (lookupVarEnv fvs id) -lookupFVInfo :: FreeVarsInfo -> Id -> StgBinderInfo --- Find how the given Id is used. --- Externally visible things may be used any old how -lookupFVInfo fvs id - | isExternalName (idName id) = noBinderInfo - | otherwise = case lookupVarEnv fvs id of - Nothing -> noBinderInfo - Just (_,_,info) -> info - -- Non-top-level things only, both type variables and ids getFVs :: FreeVarsInfo -> [Var] -getFVs fvs = [id | (id, how_bound, _) <- nonDetEltsUFM fvs, +getFVs fvs = [id | (id, how_bound) <- nonDetEltsUFM fvs, -- It's OK to use nonDetEltsUFM here because we're not aiming for -- bit-for-bit determinism. -- See Note [Unique Determinism and code generation] not (topLevelBound how_bound) ] -plusFVInfo :: (Var, HowBound, StgBinderInfo) - -> (Var, HowBound, StgBinderInfo) - -> (Var, HowBound, StgBinderInfo) -plusFVInfo (id1,hb1,info1) (id2,hb2,info2) +plusFVInfo :: (Var, HowBound) + -> (Var, HowBound) + -> (Var, HowBound) +plusFVInfo (id1,hb1) (id2,hb2) = ASSERT(id1 == id2 && hb1 == hb2) - (id1, hb1, combineStgBinderInfo info1 info2) + (id1, hb1) -- Misc. |