X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fstranal%2FStrictAnal.lhs;h=d143a15b86d5375b0b7f34b2fbfc22661fff9065;hb=06e14415fa8aef5be7d01314d08fcd87873cd0da;hp=1bc847424ad7d341cf701bac5c383da1854b5f61;hpb=438596897ebbe25a07e1c82085cfbc5bdb00f09e;p=ghc-hetmet.git diff --git a/ghc/compiler/stranal/StrictAnal.lhs b/ghc/compiler/stranal/StrictAnal.lhs index 1bc8474..d143a15 100644 --- a/ghc/compiler/stranal/StrictAnal.lhs +++ b/ghc/compiler/stranal/StrictAnal.lhs @@ -7,26 +7,30 @@ The original version(s) of all strictness-analyser code (except the Semantique analyser) was written by Andy Gill. \begin{code} -module StrictAnal ( saWwTopBinds ) where +#ifndef OLD_STRICTNESS +module StrictAnal ( ) where + +#else + +module StrictAnal ( saBinds ) where #include "HsVersions.h" -import CmdLineOpts ( opt_D_dump_stranal, opt_D_simplifier_stats, opt_D_verbose_core2core ) +import CmdLineOpts ( DynFlags, DynFlag(..) ) import CoreSyn -import Id ( idType, setIdStrictness, - getIdDemandInfo, setIdDemandInfo, +import Id ( setIdStrictness, setInlinePragma, + idDemandInfo, setIdDemandInfo, isBottomingId, Id ) -import IdInfo ( mkStrictnessInfo, mkBottomStrictnessInfo ) -import CoreLint ( beginPass, endPass ) -import ErrUtils ( dumpIfSet ) +import CoreLint ( showPass, endPass ) +import ErrUtils ( dumpIfSet_dyn ) import SaAbsInt import SaLib -import Demand ( isStrict ) -import WorkWrap -- "back-end" of strictness analyser -import UniqSupply ( UniqSupply ) -import Util ( zipWith4Equal ) +import Demand ( Demand, wwStrict, isStrict, isLazy ) +import Util ( zipWith3Equal, stretchZipWith, compareLength ) +import BasicTypes ( Activation( NeverActive ) ) import Outputable +import FastTypes \end{code} %************************************************************************ @@ -75,29 +79,27 @@ Alas and alack. %* * %************************************************************************ -\begin{code} -saWwTopBinds :: UniqSupply - -> [CoreBind] - -> IO [CoreBind] +@saBinds@ decorates bindings with strictness info. A later +worker-wrapper pass can use this info to create wrappers and +strict workers. -saWwTopBinds us binds +\begin{code} +saBinds :: DynFlags -> [CoreBind] -> IO [CoreBind] +saBinds dflags binds = do { - beginPass "Strictness analysis"; + showPass dflags "Strictness analysis"; -- Mark each binder with its strictness #ifndef OMIT_STRANAL_STATS let { (binds_w_strictness, sa_stats) = saTopBinds binds nullSaStats }; - dumpIfSet opt_D_simplifier_stats "Strictness analysis statistics" + dumpIfSet_dyn dflags Opt_D_dump_simpl_stats "Strictness analysis statistics" (pp_stats sa_stats); #else let { binds_w_strictness = saTopBindsBinds binds }; #endif - -- Create worker/wrappers, and mark binders with their - -- "strictness info" [which encodes their worker/wrapper-ness] - let { binds' = workersAndWrappers us binds_w_strictness }; - - endPass "Strictness analysis" (opt_D_dump_stranal || opt_D_verbose_core2core) binds' + endPass dflags "Strictness analysis" Opt_D_dump_stranal + binds_w_strictness } \end{code} @@ -149,7 +151,7 @@ saTopBind :: StrictEnv -> AbsenceEnv -> SaM (StrictEnv, AbsenceEnv, CoreBind) saTopBind str_env abs_env (NonRec binder rhs) - = saExpr str_env abs_env rhs `thenSa` \ new_rhs -> + = saExpr minDemand str_env abs_env rhs `thenSa` \ new_rhs -> let str_rhs = absEval StrAnal rhs str_env abs_rhs = absEval AbsAnal rhs abs_env @@ -160,10 +162,9 @@ saTopBind str_env abs_env (NonRec binder rhs) -- See notes on Let case in SaAbsInt.lhs new_binder - = addStrictnessInfoToId + = addStrictnessInfoToTopId widened_str_rhs widened_abs_rhs binder - rhs -- Augment environments with a mapping of the -- binder to its abstract values, computed by absEval @@ -180,14 +181,25 @@ saTopBind str_env abs_env (Rec pairs) -- fixpoint returns widened values new_str_env = growAbsValEnvList str_env (binders `zip` str_rhss) new_abs_env = growAbsValEnvList abs_env (binders `zip` abs_rhss) - new_binders = zipWith4Equal "saTopBind" addStrictnessInfoToId - str_rhss abs_rhss binders rhss + new_binders = zipWith3Equal "saTopBind" addStrictnessInfoToTopId + str_rhss abs_rhss binders in - mapSa (saExpr new_str_env new_abs_env) rhss `thenSa` \ new_rhss -> + mapSa (saExpr minDemand new_str_env new_abs_env) rhss `thenSa` \ new_rhss -> let new_pairs = new_binders `zip` new_rhss in returnSa (new_str_env, new_abs_env, Rec new_pairs) + +-- Hack alert! +-- Top level divergent bindings are marked NOINLINE +-- This avoids fruitless inlining of top level error functions +addStrictnessInfoToTopId str_val abs_val bndr + = if isBottomingId new_id then + new_id `setInlinePragma` NeverActive + else + new_id + where + new_id = addStrictnessInfoToId str_val abs_val bndr \end{code} %************************************************************************ @@ -200,49 +212,86 @@ saTopBind str_env abs_env (Rec pairs) environment. \begin{code} -saExpr :: StrictEnv -> AbsenceEnv -> CoreExpr -> SaM CoreExpr - -saExpr _ _ e@(Var _) = returnSa e -saExpr _ _ e@(Con _ _) = returnSa e -saExpr _ _ e@(Type _) = returnSa e - -saExpr str_env abs_env (Lam bndr body) +saExpr :: Demand -> StrictEnv -> AbsenceEnv -> CoreExpr -> SaM CoreExpr + -- The demand is the least demand we expect on the + -- expression. WwStrict is the least, because we're only + -- interested in the expression at all if it's being evaluated, + -- but the demand may be more. E.g. + -- f E + -- where f has strictness u(LL), will evaluate E with demand u(LL) + +minDemand = wwStrict +minDemands = repeat minDemand + +-- When we find an application, do the arguments +-- with demands gotten from the function +saApp str_env abs_env (fun, args) + = sequenceSa sa_args `thenSa` \ args' -> + saExpr minDemand str_env abs_env fun `thenSa` \ fun' -> + returnSa (mkApps fun' args') + where + arg_dmds = case fun of + Var var -> case lookupAbsValEnv str_env var of + Just (AbsApproxFun ds _) + | compareLength ds args /= LT + -- 'ds' is at least as long as 'args'. + -> ds ++ minDemands + other -> minDemands + other -> minDemands + + sa_args = stretchZipWith isTypeArg (error "saApp:dmd") + sa_arg args arg_dmds + -- The arg_dmds are for value args only, we need to skip + -- over the type args when pairing up with the demands + -- Hence the stretchZipWith + + sa_arg arg dmd = saExpr dmd' str_env abs_env arg + where + -- Bring arg demand up to minDemand + dmd' | isLazy dmd = minDemand + | otherwise = dmd + +saExpr _ _ _ e@(Var _) = returnSa e +saExpr _ _ _ e@(Lit _) = returnSa e +saExpr _ _ _ e@(Type _) = returnSa e + +saExpr dmd str_env abs_env (Lam bndr body) = -- Don't bother to set the demand-info on a lambda binder -- We do that only for let(rec)-bound functions - saExpr str_env abs_env body `thenSa` \ new_body -> + saExpr minDemand str_env abs_env body `thenSa` \ new_body -> returnSa (Lam bndr new_body) -saExpr str_env abs_env (App fun arg) - = saExpr str_env abs_env fun `thenSa` \ new_fun -> - saExpr str_env abs_env arg `thenSa` \ new_arg -> - returnSa (App new_fun new_arg) +saExpr dmd str_env abs_env e@(App fun arg) + = saApp str_env abs_env (collectArgs e) -saExpr str_env abs_env (Note note expr) - = saExpr str_env abs_env expr `thenSa` \ new_expr -> +saExpr dmd str_env abs_env (Note note expr) + = saExpr dmd str_env abs_env expr `thenSa` \ new_expr -> returnSa (Note note new_expr) -saExpr str_env abs_env (Case expr case_bndr alts) - = saExpr str_env abs_env expr `thenSa` \ new_expr -> - mapSa sa_alt alts `thenSa` \ new_alts -> +saExpr dmd str_env abs_env (Case expr case_bndr alts) + = saExpr minDemand str_env abs_env expr `thenSa` \ new_expr -> + mapSa sa_alt alts `thenSa` \ new_alts -> let - new_case_bndr = addDemandInfoToCaseBndr str_env abs_env alts case_bndr + new_case_bndr = addDemandInfoToCaseBndr dmd str_env abs_env alts case_bndr in returnSa (Case new_expr new_case_bndr new_alts) where sa_alt (con, binders, rhs) - = saExpr str_env abs_env rhs `thenSa` \ new_rhs -> + = saExpr dmd str_env abs_env rhs `thenSa` \ new_rhs -> let new_binders = map add_demand_info binders add_demand_info bndr | isTyVar bndr = bndr - | otherwise = addDemandInfoToId str_env abs_env rhs bndr + | otherwise = addDemandInfoToId dmd str_env abs_env rhs bndr in tickCases new_binders `thenSa_` -- stats returnSa (con, new_binders, new_rhs) -saExpr str_env abs_env (Let (NonRec binder rhs) body) +saExpr dmd str_env abs_env (Let (NonRec binder rhs) body) = -- Analyse the RHS in the environment at hand - saExpr str_env abs_env rhs `thenSa` \ new_rhs -> let + -- Find the demand on the RHS + rhs_dmd = findDemand dmd str_env abs_env body binder + -- Bind this binder to the abstract value of the RHS; analyse -- the body of the `let' in the extended environment. str_rhs_val = absEval StrAnal rhs str_env @@ -260,14 +309,14 @@ saExpr str_env abs_env (Let (NonRec binder rhs) body) -- to record DemandInfo/StrictnessInfo in the binder. new_binder = addStrictnessInfoToId widened_str_rhs widened_abs_rhs - (addDemandInfoToId str_env abs_env body binder) - rhs + (binder `setIdDemandInfo` rhs_dmd) in - tickLet new_binder `thenSa_` -- stats - saExpr new_str_env new_abs_env body `thenSa` \ new_body -> + tickLet new_binder `thenSa_` -- stats + saExpr rhs_dmd str_env abs_env rhs `thenSa` \ new_rhs -> + saExpr dmd new_str_env new_abs_env body `thenSa` \ new_body -> returnSa (Let (NonRec new_binder new_rhs) new_body) -saExpr str_env abs_env (Let (Rec pairs) body) +saExpr dmd str_env abs_env (Let (Rec pairs) body) = let (binders,rhss) = unzip pairs str_vals = fixpoint StrAnal binders rhss str_env @@ -276,10 +325,9 @@ saExpr str_env abs_env (Let (Rec pairs) body) new_str_env = growAbsValEnvList str_env (binders `zip` str_vals) new_abs_env = growAbsValEnvList abs_env (binders `zip` abs_vals) in - saExpr new_str_env new_abs_env body `thenSa` \ new_body -> - mapSa (saExpr new_str_env new_abs_env) rhss `thenSa` \ new_rhss -> + saExpr dmd new_str_env new_abs_env body `thenSa` \ new_body -> + mapSa (saExpr minDemand new_str_env new_abs_env) rhss `thenSa` \ new_rhss -> let --- new_binders = addDemandInfoToIds new_str_env new_abs_env body binders -- DON'T add demand info in a Rec! -- a) it's useless: we can't do let-to-case -- b) it's incorrect. Consider @@ -291,8 +339,8 @@ saExpr str_env abs_env (Let (Rec pairs) body) -- deciding that y is absent, which is plain wrong! -- It's much easier simply not to do this. - improved_binders = zipWith4Equal "saExpr" addStrictnessInfoToId - str_vals abs_vals binders rhss + improved_binders = zipWith3Equal "saExpr" addStrictnessInfoToId + str_vals abs_vals binders new_pairs = improved_binders `zip` new_rhss in @@ -322,40 +370,23 @@ addStrictnessInfoToId :: AbsVal -- Abstract strictness value -> AbsVal -- Ditto absence -> Id -- The id - -> CoreExpr -- Its RHS -> Id -- Augmented with strictness -addStrictnessInfoToId str_val abs_val binder body - - | isBot str_val - = binder `setIdStrictness` mkBottomStrictnessInfo - - | otherwise - = case (collectTyAndValBinders body) of - (_, [], rhs) -> binder - (_, lambda_bounds, rhs) -> binder `setIdStrictness` - mkStrictnessInfo strictness False - where - tys = map idType lambda_bounds - strictness = findStrictness tys str_val abs_val +addStrictnessInfoToId str_val abs_val binder + = binder `setIdStrictness` findStrictness binder str_val abs_val \end{code} \begin{code} -addDemandInfoToId :: StrictEnv -> AbsenceEnv +addDemandInfoToId :: Demand -> StrictEnv -> AbsenceEnv -> CoreExpr -- The scope of the id -> Id -> Id -- Id augmented with Demand info -addDemandInfoToId str_env abs_env expr binder - = binder `setIdDemandInfo` (findDemand str_env abs_env expr binder) - -addDemandInfoToCaseBndr str_env abs_env alts binder - = binder `setIdDemandInfo` (findDemandAlts str_env abs_env alts binder) - -addDemandInfoToIds :: StrictEnv -> AbsenceEnv -> CoreExpr -> [Id] -> [Id] +addDemandInfoToId dmd str_env abs_env expr binder + = binder `setIdDemandInfo` (findDemand dmd str_env abs_env expr binder) -addDemandInfoToIds str_env abs_env expr binders - = map (addDemandInfoToId str_env abs_env expr) binders +addDemandInfoToCaseBndr dmd str_env abs_env alts binder + = binder `setIdDemandInfo` (findDemandAlts dmd str_env abs_env alts binder) \end{code} %************************************************************************ @@ -366,12 +397,12 @@ addDemandInfoToIds str_env abs_env expr binders \begin{code} data SaStats - = SaStats FAST_INT FAST_INT -- total/marked-demanded lambda-bound - FAST_INT FAST_INT -- total/marked-demanded case-bound - FAST_INT FAST_INT -- total/marked-demanded let-bound + = SaStats FastInt FastInt -- total/marked-demanded lambda-bound + FastInt FastInt -- total/marked-demanded case-bound + FastInt FastInt -- total/marked-demanded let-bound -- (excl. top-level; excl. letrecs) -nullSaStats = SaStats ILIT(0) ILIT(0) ILIT(0) ILIT(0) ILIT(0) ILIT(0) +nullSaStats = SaStats (_ILIT 0) (_ILIT 0) (_ILIT 0) (_ILIT 0) (_ILIT 0) (_ILIT 0) thenSa :: SaM a -> (a -> SaM b) -> SaM b thenSa_ :: SaM a -> SaM b -> SaM b @@ -399,32 +430,38 @@ thenSa_ expr cont stats returnSa x stats = (x, stats) tickLambda var (SaStats tlam dlam tc dc tlet dlet) - = case (tick_demanded var (0,0)) of { (IBOX(tot), IBOX(demanded)) -> - ((), SaStats (tlam _ADD_ tot) (dlam _ADD_ demanded) tc dc tlet dlet) } + = case (tick_demanded var (0,0)) of { (totB, demandedB) -> + let tot = iUnbox totB ; demanded = iUnbox demandedB + in + ((), SaStats (tlam +# tot) (dlam +# demanded) tc dc tlet dlet) } tickCases vars (SaStats tlam dlam tc dc tlet dlet) - = case (foldr tick_demanded (0,0) vars) of { (IBOX(tot), IBOX(demanded)) -> - ((), SaStats tlam dlam (tc _ADD_ tot) (dc _ADD_ demanded) tlet dlet) } + = case (foldr tick_demanded (0,0) vars) of { (totB, demandedB) -> + let tot = iUnbox totB ; demanded = iUnbox demandedB + in + ((), SaStats tlam dlam (tc +# tot) (dc +# demanded) tlet dlet) } tickLet var (SaStats tlam dlam tc dc tlet dlet) - = case (tick_demanded var (0,0)) of { (IBOX(tot),IBOX(demanded)) -> - ((), SaStats tlam dlam tc dc (tlet _ADD_ tot) (dlet _ADD_ demanded)) } + = case (tick_demanded var (0,0)) of { (totB, demandedB) -> + let tot = iUnbox totB ; demanded = iUnbox demandedB + in + ((), SaStats tlam dlam tc dc (tlet +# tot) (dlet +# demanded)) } tick_demanded var (tot, demanded) | isTyVar var = (tot, demanded) | otherwise = (tot + 1, - if (isStrict (getIdDemandInfo var)) + if (isStrict (idDemandInfo var)) then demanded + 1 else demanded) pp_stats (SaStats tlam dlam tc dc tlet dlet) - = hcat [ptext SLIT("Lambda vars: "), int IBOX(dlam), char '/', int IBOX(tlam), - ptext SLIT("; Case vars: "), int IBOX(dc), char '/', int IBOX(tc), - ptext SLIT("; Let vars: "), int IBOX(dlet), char '/', int IBOX(tlet) + = hcat [ptext SLIT("Lambda vars: "), int (iBox dlam), char '/', int (iBox tlam), + ptext SLIT("; Case vars: "), int (iBox dc), char '/', int (iBox tc), + ptext SLIT("; Let vars: "), int (iBox dlet), char '/', int (iBox tlet) ] -#else {-OMIT_STRANAL_STATS-} +#else /* OMIT_STRANAL_STATS */ -- identity monad type SaM a = a @@ -438,13 +475,20 @@ tickLambda var = panic "OMIT_STRANAL_STATS: tickLambda" tickCases vars = panic "OMIT_STRANAL_STATS: tickCases" tickLet var = panic "OMIT_STRANAL_STATS: tickLet" -#endif {-OMIT_STRANAL_STATS-} +#endif /* OMIT_STRANAL_STATS */ mapSa :: (a -> SaM b) -> [a] -> SaM [b] mapSa f [] = returnSa [] -mapSa f (x:xs) - = f x `thenSa` \ r -> - mapSa f xs `thenSa` \ rs -> - returnSa (r:rs) +mapSa f (x:xs) = f x `thenSa` \ r -> + mapSa f xs `thenSa` \ rs -> + returnSa (r:rs) + +sequenceSa :: [SaM a] -> SaM [a] +sequenceSa [] = returnSa [] +sequenceSa (m:ms) = m `thenSa` \ r -> + sequenceSa ms `thenSa` \ rs -> + returnSa (r:rs) + +#endif /* OLD_STRICTNESS */ \end{code}