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 ( setIdStrictness, setInlinePragma,
idDemandInfo, setIdDemandInfo, isBottomingId,
Id
)
-import IdInfo ( neverInlinePrag )
-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 Util ( zipWith3Equal, stretchZipWith )
+import Util ( zipWith3Equal, stretchZipWith, compareLength )
+import BasicTypes ( Activation( NeverActive ) )
import Outputable
+import FastTypes
\end{code}
%************************************************************************
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}
-- This avoids fruitless inlining of top level error functions
addStrictnessInfoToTopId str_val abs_val bndr
= if isBottomingId new_id then
- new_id `setInlinePragma` neverInlinePrag
+ new_id `setInlinePragma` NeverActive
else
new_id
where
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
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
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)) ->
+ = 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)) ->
+ = 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)) ->
+ = 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)
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-}
sequenceSa (m:ms) = m `thenSa` \ r ->
sequenceSa ms `thenSa` \ rs ->
returnSa (r:rs)
+
+#endif /* OLD_STRICTNESS */
\end{code}