%
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
%
\section[StrictAnal]{``Simple'' Mycroft-style strictness analyser}
Semantique analyser) was written by Andy Gill.
\begin{code}
-#include "HsVersions.h"
-
-module StrictAnal ( saWwTopBinds, saTopBinds ) where
+module StrictAnal ( saBinds ) where
-IMPORT_Trace
-import Outputable
-import Pretty
+#include "HsVersions.h"
-import CmdLineOpts ( GlobalSwitch(..) )
-import CoreSyn -- ToDo: get pprCoreBinding straight from PlainCore?
-import Id ( addIdDemandInfo, isWrapperId, addIdStrictness,
- getIdUniType, getIdDemandInfo
- IF_ATTACK_PRAGMAS(COMMA getIdStrictness) -- profiling
+import CmdLineOpts ( DynFlags, DynFlag(..) )
+import CoreSyn
+import Id ( setIdStrictness, setInlinePragma,
+ idDemandInfo, setIdDemandInfo, isBottomingId,
+ Id
)
-import IdEnv
-import IdInfo
-import PlainCore
+import IdInfo ( neverInlinePrag )
+import CoreLint ( showPass, endPass )
+import ErrUtils ( dumpIfSet_dyn )
import SaAbsInt
import SaLib
-import SplitUniq
-import Unique
-import Util
-import WorkWrap -- "back-end" of strictness analyser
-import WwLib ( WwM(..) )
+import Demand ( Demand, wwStrict, isStrict, isLazy )
+import Util ( zipWith3Equal, stretchZipWith )
+import Outputable
+import FastTypes
\end{code}
-
%************************************************************************
%* *
\subsection[Thoughts]{Random thoughts}
and we deduce that f is strict, it is nevertheless NOT safe to worker-wapper to
f = \x -> case x of Int x# -> fw x#
- fw = \x# -> let x = Int x#
- in
+ fw = \x# -> let x = Int x#
+ in
let v = <expensive>
in <body>
-because this obviously loses laziness, since now <expensive>
+because this obviously loses laziness, since now <expensive>
is done each time. Alas.
WATCH OUT! This can mean that something is unboxed only to be
%* *
%************************************************************************
+@saBinds@ decorates bindings with strictness info. A later
+worker-wrapper pass can use this info to create wrappers and
+strict workers.
+
\begin{code}
-saWwTopBinds :: SplitUniqSupply
- -> (GlobalSwitch -> Bool)
- -> [PlainCoreBinding]
- -> [PlainCoreBinding]
+saBinds :: DynFlags -> [CoreBind] -> IO [CoreBind]
-saWwTopBinds us switch_chker binds
- = let
- strflags = (switch_chker AllStrict, switch_chker NumbersStrict)
+saBinds dflags binds
+ = do {
+ showPass dflags "Strictness analysis";
- -- mark each binder with its strictness
-#ifndef OMIT_STRANAL_STATS
- (binds_w_strictness, sa_stats)
- = sa_top_binds strflags binds nullSaStats
-#else
- binds_w_strictness
- = sa_top_binds strflags binds
-#endif
- in
- -- possibly show what we decided about strictness...
- (if switch_chker D_dump_stranal
- then pprTrace "Strictness:\n" (ppAboves (
- map (pprCoreBinding PprDebug pprBigCoreBinder pprBigCoreBinder ppr) binds_w_strictness))
- else id
- )
- -- possibly show how many things we marked as demanded...
- ((if switch_chker D_simplifier_stats
+ -- Mark each binder with its strictness
#ifndef OMIT_STRANAL_STATS
- then pp_stats sa_stats
+ let { (binds_w_strictness, sa_stats) = saTopBinds binds nullSaStats };
+ dumpIfSet_dyn dflags Opt_D_dump_simpl_stats "Strictness analysis statistics"
+ (pp_stats sa_stats);
#else
- then id
-#endif
- else id
- )
- -- create worker/wrappers, and mark binders with their
- -- "strictness info" [which encodes their
- -- worker/wrapper-ness]
- (workersAndWrappers binds_w_strictness us switch_chker))
-#ifndef OMIT_STRANAL_STATS
- where
- pp_stats (SaStats tlam dlam tc dc tlet dlet)
- = pprTrace "Binders marked demanded: "
- (ppBesides [ppStr "Lambda vars: ", ppInt IBOX(dlam), ppChar '/', ppInt IBOX(tlam),
- ppStr "; Case vars: ", ppInt IBOX(dc), ppChar '/', ppInt IBOX(tc),
- ppStr "; Let vars: ", ppInt IBOX(dlet), ppChar '/', ppInt IBOX(tlet)
- ])
+ let { binds_w_strictness = saTopBindsBinds binds };
#endif
+
+ endPass dflags "Strictness analysis" Opt_D_dump_stranal
+ binds_w_strictness
+ }
\end{code}
%************************************************************************
@AbsValEnv@ maps an @Id@ to its @AbsVal@).
\begin{code}
-saTopBinds :: StrAnalFlags -> [PlainCoreBinding] -> [PlainCoreBinding] -- exported
-sa_top_binds :: StrAnalFlags -> [PlainCoreBinding] -> SaM [PlainCoreBinding] -- not exported
+saTopBinds :: [CoreBind] -> SaM [CoreBind] -- not exported
-saTopBinds strflags binds
-#ifndef OMIT_STRANAL_STATS
- = fst (sa_top_binds strflags binds nullSaStats)
-#else
- = sa_top_binds strflags binds
-#endif
-
-sa_top_binds strflags binds
+saTopBinds binds
= let
- starting_abs_env = nullAbsValEnv strflags
+ starting_abs_env = nullAbsValEnv
in
do_it starting_abs_env starting_abs_env binds
where
\begin{code}
saTopBind :: StrictEnv -> AbsenceEnv
- -> PlainCoreBinding
- -> SaM (StrictEnv, AbsenceEnv, PlainCoreBinding)
+ -> CoreBind
+ -> SaM (StrictEnv, AbsenceEnv, CoreBind)
-saTopBind str_env abs_env (CoNonRec binder rhs)
- = saExpr str_env abs_env rhs `thenSa` \ new_rhs ->
+saTopBind str_env abs_env (NonRec binder rhs)
+ = saExpr minDemand str_env abs_env rhs `thenSa` \ new_rhs ->
let
- strflags = getStrAnalFlags str_env
-
str_rhs = absEval StrAnal rhs str_env
abs_rhs = absEval AbsAnal rhs abs_env
widened_str_rhs = widen StrAnal str_rhs
widened_abs_rhs = widen AbsAnal abs_rhs
-- The widening above is done for efficiency reasons.
- -- See notes on CoLet case in SaAbsInt.lhs
+ -- See notes on Let case in SaAbsInt.lhs
new_binder
- = addStrictnessInfoToId
- strflags
+ = addStrictnessInfoToTopId
widened_str_rhs widened_abs_rhs
binder
- rhs
-- Augment environments with a mapping of the
-- binder to its abstract values, computed by absEval
new_str_env = addOneToAbsValEnv str_env binder widened_str_rhs
new_abs_env = addOneToAbsValEnv abs_env binder widened_abs_rhs
in
- returnSa (new_str_env, new_abs_env, CoNonRec new_binder new_rhs)
+ returnSa (new_str_env, new_abs_env, NonRec new_binder new_rhs)
-saTopBind str_env abs_env (CoRec pairs)
+saTopBind str_env abs_env (Rec pairs)
= let
- strflags = getStrAnalFlags str_env
(binders,rhss) = unzip pairs
str_rhss = fixpoint StrAnal binders rhss str_env
abs_rhss = fixpoint AbsAnal binders rhss abs_env
-- 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 = zipWith4 (addStrictnessInfoToId strflags)
- 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, CoRec new_pairs)
+ 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` neverInlinePrag
+ else
+ new_id
+ where
+ new_id = addStrictnessInfoToId str_val abs_val bndr
\end{code}
%************************************************************************
environment.
\begin{code}
-saExpr :: StrictEnv -> AbsenceEnv -> PlainCoreExpr -> SaM PlainCoreExpr
-
-saExpr _ _ e@(CoVar _) = returnSa e
-saExpr _ _ e@(CoLit _) = returnSa e
-saExpr _ _ e@(CoCon _ _ _) = returnSa e
-saExpr _ _ e@(CoPrim _ _ _) = returnSa e
-
-saExpr str_env abs_env (CoLam args body)
- = saExpr str_env abs_env body `thenSa` \ new_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 _) | length ds >= length 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 minDemand str_env abs_env body `thenSa` \ new_body ->
+ returnSa (Lam bndr new_body)
+
+saExpr dmd str_env abs_env e@(App fun arg)
+ = saApp str_env abs_env (collectArgs e)
+
+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 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_args = addDemandInfoToIds str_env abs_env body args
+ new_case_bndr = addDemandInfoToCaseBndr dmd str_env abs_env alts case_bndr
in
- tickLambdas new_args `thenSa_` -- stats
- returnSa (CoLam new_args new_body)
-
-saExpr str_env abs_env (CoTyLam ty expr)
- = saExpr str_env abs_env expr `thenSa` \ new_expr ->
- returnSa (CoTyLam ty new_expr)
-
-saExpr str_env abs_env (CoApp fun arg)
- = saExpr str_env abs_env fun `thenSa` \ new_fun ->
- returnSa (CoApp new_fun arg)
-
-saExpr str_env abs_env (CoTyApp expr ty)
- = saExpr str_env abs_env expr `thenSa` \ new_expr ->
- returnSa (CoTyApp new_expr ty)
-
-saExpr str_env abs_env (CoSCC cc expr)
- = saExpr str_env abs_env expr `thenSa` \ new_expr ->
- returnSa (CoSCC cc new_expr)
-
-saExpr str_env abs_env (CoCase expr (CoAlgAlts alts deflt))
- = saExpr str_env abs_env expr `thenSa` \ new_expr ->
- saDefault str_env abs_env deflt `thenSa` \ new_deflt ->
- mapSa sa_alt alts `thenSa` \ new_alts ->
- returnSa (CoCase new_expr (CoAlgAlts new_alts new_deflt))
+ 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 = addDemandInfoToIds str_env abs_env rhs binders
+ new_binders = map add_demand_info binders
+ add_demand_info bndr | isTyVar bndr = 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 (CoCase expr (CoPrimAlts alts deflt))
- = saExpr str_env abs_env expr `thenSa` \ new_expr ->
- saDefault str_env abs_env deflt `thenSa` \ new_deflt ->
- mapSa sa_alt alts `thenSa` \ new_alts ->
- returnSa (CoCase new_expr (CoPrimAlts new_alts new_deflt))
- where
- sa_alt (lit, rhs)
- = saExpr str_env abs_env rhs `thenSa` \ new_rhs ->
- returnSa (lit, new_rhs)
-
-saExpr str_env abs_env (CoLet (CoNonRec 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
- strflags = getStrAnalFlags str_env
+ -- 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.
widened_str_rhs = widen StrAnal str_rhs_val
widened_abs_rhs = widen AbsAnal abs_rhs_val
-- The widening above is done for efficiency reasons.
- -- See notes on CoLet case in SaAbsInt.lhs
+ -- See notes on Let case in SaAbsInt.lhs
new_str_env = addOneToAbsValEnv str_env binder widened_str_rhs
new_abs_env = addOneToAbsValEnv abs_env binder widened_abs_rhs
-- Now determine the strictness of this binder; use that info
-- to record DemandInfo/StrictnessInfo in the binder.
- new_binder = addStrictnessInfoToId strflags
+ 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 ->
- returnSa (CoLet (CoNonRec new_binder new_rhs) 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 (CoLet (CoRec pairs) body)
+saExpr dmd str_env abs_env (Let (Rec pairs) body)
= let
- strflags = getStrAnalFlags str_env
(binders,rhss) = unzip pairs
str_vals = fixpoint StrAnal binders rhss str_env
abs_vals = fixpoint AbsAnal binders rhss abs_env
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 CoRec!
+-- DON'T add demand info in a Rec!
-- a) it's useless: we can't do let-to-case
-- b) it's incorrect. Consider
-- letrec x = ...y...
-- deciding that y is absent, which is plain wrong!
-- It's much easier simply not to do this.
- improved_binders = zipWith4 (addStrictnessInfoToId strflags)
- str_vals abs_vals binders rhss
-
- whiter_than_white_binders = launder improved_binders
-
- new_pairs = whiter_than_white_binders `zip` new_rhss
- in
- returnSa (CoLet (CoRec new_pairs) new_body)
- where
- launder me = {-still-} me
-\end{code}
-
-\begin{code}
-saDefault str_env abs_env CoNoDefault = returnSa CoNoDefault
+ improved_binders = zipWith3Equal "saExpr" addStrictnessInfoToId
+ str_vals abs_vals binders
-saDefault str_env abs_env (CoBindDefault bdr rhs)
- = saExpr str_env abs_env rhs `thenSa` \ new_rhs ->
- let
- new_bdr = addDemandInfoToId str_env abs_env rhs bdr
+ new_pairs = improved_binders `zip` new_rhss
in
- tickCases [new_bdr] `thenSa_` -- stats
- returnSa (CoBindDefault new_bdr new_rhs)
+ returnSa (Let (Rec new_pairs) new_body)
\end{code}
tell how many args could safely be grabbed.
\begin{code}
-addStrictnessInfoToId
- :: StrAnalFlags
- -> AbsVal -- Abstract strictness value
+addStrictnessInfoToId
+ :: AbsVal -- Abstract strictness value
-> AbsVal -- Ditto absence
-> Id -- The id
- -> PlainCoreExpr -- Its RHS
-> Id -- Augmented with strictness
-addStrictnessInfoToId strflags str_val abs_val binder body
- = if isWrapperId binder then
- binder -- Avoid clobbering existing strictness info
- -- (and, more importantly, worker info).
- -- Deeply suspicious (SLPJ)
- else
- if (isBot str_val) then
- binder `addIdStrictness` mkBottomStrictnessInfo
- else
- case (digForLambdas body) of { (_, lambda_bounds, rhs) ->
- let
- tys = map getIdUniType lambda_bounds
- strictness = findStrictness strflags tys str_val abs_val
- in
- binder `addIdStrictness` mkStrictnessInfo strictness Nothing
- }
+addStrictnessInfoToId str_val abs_val binder
+ = binder `setIdStrictness` findStrictness binder str_val abs_val
\end{code}
\begin{code}
-addDemandInfoToId :: StrictEnv -> AbsenceEnv
- -> PlainCoreExpr -- The scope of the id
- -> Id
+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 `addIdDemandInfo` (mkDemandInfo (findDemand str_env abs_env expr binder))
-
-addDemandInfoToIds :: StrictEnv -> AbsenceEnv -> PlainCoreExpr -> [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}
%************************************************************************
\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
returnSa :: a -> SaM a
-#ifdef __GLASGOW_HASKELL__
{-# INLINE thenSa #-}
{-# INLINE thenSa_ #-}
{-# INLINE returnSa #-}
-#endif
-tickLambdas :: [Id] -> SaM ()
-tickCases :: [Id] -> SaM ()
-tickLet :: Id -> SaM ()
+tickLambda :: Id -> SaM ()
+tickCases :: [CoreBndr] -> SaM ()
+tickLet :: Id -> SaM ()
#ifndef OMIT_STRANAL_STATS
type SaM a = SaStats -> (a, SaStats)
returnSa x stats = (x, stats)
-tickLambdas vars (SaStats tlam dlam tc dc tlet dlet)
- = case (foldr tick_demanded (0,0) vars) of { (IBOX(tot), IBOX(demanded)) ->
- ((), SaStats (tlam _ADD_ tot) (dlam _ADD_ demanded) tc dc tlet dlet) }
+tickLambda var (SaStats tlam dlam 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 (willBeDemanded (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)
+ ]
+
#else {-OMIT_STRANAL_STATS-}
-- identity monad
type SaM a = a
returnSa x = x
-tickLambdas vars = panic "OMIT_STRANAL_STATS: tickLambdas"
-tickCases vars = panic "OMIT_STRANAL_STATS: tickCases"
-tickLet var = panic "OMIT_STRANAL_STATS: tickLet"
+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-}
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)
\end{code}