X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fstranal%2FStrictAnal.lhs;h=d143a15b86d5375b0b7f34b2fbfc22661fff9065;hb=06e14415fa8aef5be7d01314d08fcd87873cd0da;hp=3e83e2218cd2fc8fbcfc4a9d9fc4eaaf48272cc0;hpb=e4b0fab5a594c4ea29ddecdf216b4887420f26a4;p=ghc-hetmet.git diff --git a/ghc/compiler/stranal/StrictAnal.lhs b/ghc/compiler/stranal/StrictAnal.lhs index 3e83e22..d143a15 100644 --- a/ghc/compiler/stranal/StrictAnal.lhs +++ b/ghc/compiler/stranal/StrictAnal.lhs @@ -7,25 +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 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} %************************************************************************ @@ -79,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} @@ -186,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 @@ -228,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 @@ -391,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 @@ -424,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) @@ -444,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 @@ -463,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] @@ -477,4 +489,6 @@ sequenceSa [] = returnSa [] sequenceSa (m:ms) = m `thenSa` \ r -> sequenceSa ms `thenSa` \ rs -> returnSa (r:rs) + +#endif /* OLD_STRICTNESS */ \end{code}