%
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
+% (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 ) where
+module StrictAnal ( saBinds ) where
-IMP_Ubiq(){-uitous-}
+#include "HsVersions.h"
-import CmdLineOpts ( opt_D_dump_stranal, opt_D_simplifier_stats
- )
+import CmdLineOpts ( opt_D_dump_stranal, opt_D_dump_simpl_stats, opt_D_verbose_core2core )
import CoreSyn
-import Id ( idType, addIdStrictness, isWrapperId,
- getIdDemandInfo, addIdDemandInfo,
- GenId{-instance Outputable-}, SYN_IE(Id)
- )
-import IdInfo ( mkStrictnessInfo, mkBottomStrictnessInfo,
- mkDemandInfo, willBeDemanded, DemandInfo
+import Id ( idType, setIdStrictness,
+ getIdDemandInfo, setIdDemandInfo,
+ Id
)
-import PprCore ( pprCoreBinding, pprBigCoreBinder )
-import Outputable ( PprStyle(..) )
-import PprType ( GenType{-instance Outputable-}, GenTyVar{-ditto-} )
-import Pretty ( Doc, hcat, ptext, int, char, vcat )
+import IdInfo ( mkStrictnessInfo )
+import CoreLint ( beginPass, endPass )
+import ErrUtils ( dumpIfSet )
import SaAbsInt
import SaLib
-import TyVar ( GenTyVar{-instance Eq-} )
-import WorkWrap -- "back-end" of strictness analyser
-import Unique ( Unique{-instance Eq -} )
+import Demand ( isStrict )
import UniqSupply ( UniqSupply )
-import Util ( zipWith4Equal, pprTrace, panic )
+import Util ( zipWith4Equal )
+import Outputable
\end{code}
%************************************************************************
%* *
%************************************************************************
+@saBinds@ decorates bindings with strictness info. A later
+worker-wrapper pass can use this info to create wrappers and
+strict workers.
+
\begin{code}
-saWwTopBinds :: UniqSupply
- -> [CoreBinding]
- -> [CoreBinding]
+saBinds ::[CoreBind]
+ -> IO [CoreBind]
-saWwTopBinds us binds
- = let
+saBinds binds
+ = do {
+ beginPass "Strictness analysis";
- -- mark each binder with its strictness
-#ifndef OMIT_STRANAL_STATS
- (binds_w_strictness, sa_stats)
- = saTopBinds binds nullSaStats
-#else
- binds_w_strictness
- = saTopBindsBinds binds
-#endif
- in
- -- possibly show what we decided about strictness...
- (if opt_D_dump_stranal
- then pprTrace "Strictness:\n" (vcat (
- map (pprCoreBinding PprDebug) binds_w_strictness))
- else id
- )
- -- possibly show how many things we marked as demanded...
- ((if opt_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 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))
-#ifndef OMIT_STRANAL_STATS
- where
- pp_stats (SaStats tlam dlam tc dc tlet dlet)
- = pprTrace "Binders marked demanded: "
- (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)
- ])
+ let { binds_w_strictness = saTopBindsBinds binds };
#endif
+
+ endPass "Strictness analysis" (opt_D_dump_stranal || opt_D_verbose_core2core) binds_w_strictness
+ }
\end{code}
%************************************************************************
@AbsValEnv@ maps an @Id@ to its @AbsVal@).
\begin{code}
-saTopBinds :: [CoreBinding] -> SaM [CoreBinding] -- not exported
+saTopBinds :: [CoreBind] -> SaM [CoreBind] -- not exported
saTopBinds binds
= let
\begin{code}
saTopBind :: StrictEnv -> AbsenceEnv
- -> CoreBinding
- -> SaM (StrictEnv, AbsenceEnv, CoreBinding)
+ -> CoreBind
+ -> SaM (StrictEnv, AbsenceEnv, CoreBind)
saTopBind str_env abs_env (NonRec binder rhs)
= saExpr str_env abs_env rhs `thenSa` \ new_rhs ->
saExpr :: StrictEnv -> AbsenceEnv -> CoreExpr -> SaM CoreExpr
saExpr _ _ e@(Var _) = returnSa e
-saExpr _ _ e@(Lit _) = returnSa e
saExpr _ _ e@(Con _ _) = returnSa e
-saExpr _ _ e@(Prim _ _) = returnSa e
+saExpr _ _ e@(Type _) = returnSa e
-saExpr str_env abs_env (Lam (ValBinder arg) body)
- = saExpr str_env abs_env body `thenSa` \ new_body ->
- let
- new_arg = addDemandInfoToId str_env abs_env body arg
- in
- tickLambda new_arg `thenSa_` -- stats
- returnSa (Lam (ValBinder new_arg) new_body)
-
-saExpr str_env abs_env (Lam other_binder expr)
- = saExpr str_env abs_env expr `thenSa` \ new_expr ->
- returnSa (Lam other_binder new_expr)
+saExpr 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 str_env abs_env body `thenSa` \ new_body ->
+ returnSa (Lam bndr new_body)
saExpr str_env abs_env (App fun arg)
= saExpr str_env abs_env fun `thenSa` \ new_fun ->
- returnSa (App new_fun arg)
+ saExpr str_env abs_env arg `thenSa` \ new_arg ->
+ returnSa (App new_fun new_arg)
-saExpr str_env abs_env (SCC cc expr)
+saExpr str_env abs_env (Note note expr)
= saExpr str_env abs_env expr `thenSa` \ new_expr ->
- returnSa (SCC cc new_expr)
+ returnSa (Note note new_expr)
-saExpr str_env abs_env (Coerce c ty expr)
- = saExpr str_env abs_env expr `thenSa` \ new_expr ->
- returnSa (Coerce c ty new_expr)
-
-saExpr str_env abs_env (Case expr (AlgAlts 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 (Case new_expr (AlgAlts new_alts new_deflt))
+saExpr str_env abs_env (Case expr case_bndr alts)
+ = saExpr str_env abs_env expr `thenSa` \ new_expr ->
+ mapSa sa_alt alts `thenSa` \ new_alts ->
+ let
+ new_case_bndr = addDemandInfoToCaseBndr str_env abs_env alts case_bndr
+ in
+ returnSa (Case new_expr new_case_bndr new_alts)
where
sa_alt (con, binders, rhs)
= saExpr 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 str_env abs_env rhs bndr
in
tickCases new_binders `thenSa_` -- stats
returnSa (con, new_binders, new_rhs)
-saExpr str_env abs_env (Case expr (PrimAlts 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 (Case new_expr (PrimAlts 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 (Let (NonRec binder rhs) body)
= -- Analyse the RHS in the environment at hand
saExpr str_env abs_env rhs `thenSa` \ new_rhs ->
improved_binders = zipWith4Equal "saExpr" addStrictnessInfoToId
str_vals abs_vals binders rhss
- whiter_than_white_binders = launder improved_binders
-
- new_pairs = whiter_than_white_binders `zip` new_rhss
+ new_pairs = improved_binders `zip` new_rhss
in
returnSa (Let (Rec new_pairs) new_body)
- where
- launder me = {-still-} me
-\end{code}
-
-\begin{code}
-saDefault str_env abs_env NoDefault = returnSa NoDefault
-
-saDefault str_env abs_env (BindDefault bdr rhs)
- = saExpr str_env abs_env rhs `thenSa` \ new_rhs ->
- let
- new_bdr = addDemandInfoToId str_env abs_env rhs bdr
- in
- tickCases [new_bdr] `thenSa_` -- stats
- returnSa (BindDefault new_bdr new_rhs)
\end{code}
-> Id -- Augmented with strictness
addStrictnessInfoToId str_val abs_val binder body
-
- | isBot str_val
- = binder `addIdStrictness` mkBottomStrictnessInfo
-
- | otherwise
- = case (collectBinders body) of
- (_, _, [], rhs) -> binder
- (_, _, lambda_bounds, rhs) -> binder `addIdStrictness`
- mkStrictnessInfo strictness Nothing
+ = case collectBinders body of
+ -- We could use 'collectBindersIgnoringNotes', but then the
+ -- strictness info may have more items than the visible binders
+ -- used by WorkWrap.tryWW
+ (binders, rhs) -> binder `setIdStrictness`
+ mkStrictnessInfo strictness
where
- tys = map idType lambda_bounds
+ tys = [idType id | id <- binders, isId id]
strictness = findStrictness tys str_val abs_val
\end{code}
-> Id -- Id augmented with Demand info
addDemandInfoToId str_env abs_env expr binder
- = binder `addIdDemandInfo` (mkDemandInfo (findDemand str_env abs_env expr binder))
+ = binder `setIdDemandInfo` (findDemand str_env abs_env expr binder)
+
+addDemandInfoToCaseBndr str_env abs_env alts binder
+ = binder `setIdDemandInfo` (findDemandAlts str_env abs_env alts binder)
addDemandInfoToIds :: StrictEnv -> AbsenceEnv -> CoreExpr -> [Id] -> [Id]
{-# INLINE returnSa #-}
tickLambda :: Id -> SaM ()
-tickCases :: [Id] -> SaM ()
+tickCases :: [CoreBndr] -> SaM ()
tickLet :: Id -> SaM ()
#ifndef OMIT_STRANAL_STATS
((), SaStats tlam dlam tc dc (tlet _ADD_ tot) (dlet _ADD_ demanded)) }
tick_demanded var (tot, demanded)
+ | isTyVar var = (tot, demanded)
+ | otherwise
= (tot + 1,
- if (willBeDemanded (getIdDemandInfo var))
+ if (isStrict (getIdDemandInfo 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