X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fstranal%2FStrictAnal.lhs;h=d143a15b86d5375b0b7f34b2fbfc22661fff9065;hb=06e14415fa8aef5be7d01314d08fcd87873cd0da;hp=a4490cf4acedfb1574a048fdff9fcd34872909b5;hpb=111cee3f1ad93816cb828e38b38521d85c3bcebb;p=ghc-hetmet.git diff --git a/ghc/compiler/stranal/StrictAnal.lhs b/ghc/compiler/stranal/StrictAnal.lhs index a4490cf..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} +#ifndef OLD_STRICTNESS +module StrictAnal ( ) where + +#else + module StrictAnal ( saBinds ) where #include "HsVersions.h" -import CmdLineOpts ( opt_D_dump_stranal, opt_D_dump_simpl_stats, opt_D_verbose_core2core ) +import CmdLineOpts ( DynFlags, DynFlag(..) ) import CoreSyn -import Id ( idType, setIdStrictness, setInlinePragma, +import Id ( setIdStrictness, setInlinePragma, idDemandInfo, setIdDemandInfo, isBottomingId, Id ) -import IdInfo ( InlinePragInfo(..) ) -import CoreLint ( beginPass, endPass ) -import Type ( splitRepFunTys ) -import ErrUtils ( dumpIfSet ) +import CoreLint ( showPass, endPass ) +import ErrUtils ( dumpIfSet_dyn ) import SaAbsInt import SaLib import Demand ( Demand, wwStrict, isStrict, isLazy ) -import UniqSupply ( UniqSupply ) -import Util ( zipWith3Equal, stretchZipWith ) +import Util ( zipWith3Equal, stretchZipWith, compareLength ) +import BasicTypes ( Activation( NeverActive ) ) import Outputable +import FastTypes \end{code} %************************************************************************ @@ -80,23 +84,22 @@ worker-wrapper pass can use this info to create wrappers and strict workers. \begin{code} -saBinds ::[CoreBind] - -> IO [CoreBind] - -saBinds binds +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_dump_simpl_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 - endPass "Strictness analysis" (opt_D_dump_stranal || opt_D_verbose_core2core) binds_w_strictness + endPass dflags "Strictness analysis" Opt_D_dump_stranal + binds_w_strictness } \end{code} @@ -187,12 +190,12 @@ saTopBind str_env abs_env (Rec pairs) 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` IMustNotBeINLINEd False Nothing - -- This is a NOINLINE pragma + new_id `setInlinePragma` NeverActive else new_id where @@ -229,7 +232,9 @@ saApp str_env abs_env (fun, args) where arg_dmds = case fun of Var var -> case lookupAbsValEnv str_env var of - Just (AbsApproxFun ds _) | length ds >= length args + Just (AbsApproxFun ds _) + | compareLength ds args /= LT + -- 'ds' is at least as long as 'args'. -> ds ++ minDemands other -> minDemands other -> minDemands @@ -392,12 +397,12 @@ addDemandInfoToCaseBndr dmd str_env abs_env alts binder \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 @@ -425,16 +430,22 @@ 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) @@ -445,12 +456,12 @@ tick_demanded var (tot, demanded) 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 @@ -464,7 +475,7 @@ 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] @@ -478,4 +489,6 @@ sequenceSa [] = returnSa [] sequenceSa (m:ms) = m `thenSa` \ r -> sequenceSa ms `thenSa` \ rs -> returnSa (r:rs) + +#endif /* OLD_STRICTNESS */ \end{code}