X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fstranal%2FStrictAnal.lhs;h=aeb1c3fe50cef4bd4c93ef2fe63a1b371900403c;hb=95d8fef4a0af5cd0993986a98a7ec219c9aa0cd6;hp=5e8396604672f28c3f19c6eaa8b9889bbc930112;hpb=10521d8418fd3a1cf32882718b5bd28992db36fd;p=ghc-hetmet.git diff --git a/ghc/compiler/stranal/StrictAnal.lhs b/ghc/compiler/stranal/StrictAnal.lhs index 5e83966..aeb1c3f 100644 --- a/ghc/compiler/stranal/StrictAnal.lhs +++ b/ghc/compiler/stranal/StrictAnal.lhs @@ -1,5 +1,5 @@ % -% (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} @@ -7,33 +7,27 @@ The original version(s) of all strictness-analyser code (except the 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(..), dopt ) +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} @@ -49,12 +43,12 @@ A note about worker-wrappering. If we have 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 = in -because this obviously loses laziness, since now +because this obviously loses laziness, since now is done each time. Alas. WATCH OUT! This can mean that something is unboxed only to be @@ -80,53 +74,29 @@ Alas and alack. %* * %************************************************************************ +@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} %************************************************************************ @@ -151,19 +121,11 @@ environment which maps @Id@s to their abstract values (i.e., an @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 @@ -181,53 +143,59 @@ be used; we can't turn top-level @let@s into @case@s. \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} %************************************************************************ @@ -240,66 +208,83 @@ saTopBind str_env abs_env (CoRec pairs) 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. @@ -309,25 +294,24 @@ saExpr str_env abs_env (CoLet (CoNonRec binder rhs) body) 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 @@ -335,11 +319,10 @@ saExpr str_env abs_env (CoLet (CoRec 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 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... @@ -350,28 +333,12 @@ saExpr str_env abs_env (CoLet (CoRec pairs) body) -- 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} @@ -393,45 +360,27 @@ A better idea might be to have some kind of arity analysis to 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} %************************************************************************ @@ -442,26 +391,24 @@ 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 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) @@ -476,24 +423,38 @@ thenSa_ expr cont stats 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 @@ -504,17 +465,22 @@ thenSa_ expr cont = cont 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}