%
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
%
\section[StrictAnal]{``Simple'' Mycroft-style strictness analyser}
module StrictAnal ( saWwTopBinds, saTopBinds ) where
-IMPORT_Trace
-import Outputable
-import Pretty
+IMP_Ubiq(){-uitous-}
-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 ( opt_AllStrict, opt_NumbersStrict,
+ opt_D_dump_stranal, opt_D_simplifier_stats
)
-import IdEnv
-import IdInfo
-import PlainCore
+import CoreSyn
+import Id ( idType, addIdStrictness, isWrapperId,
+ getIdDemandInfo, addIdDemandInfo,
+ GenId{-instance Outputable-}
+ )
+import IdInfo ( mkStrictnessInfo, mkBottomStrictnessInfo,
+ mkDemandInfo, willBeDemanded, DemandInfo
+ )
+import PprCore ( pprCoreBinding, pprBigCoreBinder )
+import PprStyle ( PprStyle(..) )
+import PprType ( GenType{-instance Outputable-}, GenTyVar{-ditto-} )
+import Pretty ( ppBesides, ppPStr, ppInt, ppChar, ppAboves )
import SaAbsInt
import SaLib
-import SplitUniq
-import Unique
-import Util
+import TyVar ( GenTyVar{-instance Eq-} )
import WorkWrap -- "back-end" of strictness analyser
-import WwLib ( WwM(..) )
+import Unique ( Unique{-instance Eq -} )
+import Util ( zipWith4Equal, pprTrace, panic )
\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
%************************************************************************
\begin{code}
-saWwTopBinds :: SplitUniqSupply
- -> (GlobalSwitch -> Bool)
- -> [PlainCoreBinding]
- -> [PlainCoreBinding]
+saWwTopBinds :: UniqSupply
+ -> [CoreBinding]
+ -> [CoreBinding]
-saWwTopBinds us switch_chker binds
+saWwTopBinds us binds
= let
- strflags = (switch_chker AllStrict, switch_chker NumbersStrict)
+ strflags = (opt_AllStrict, opt_NumbersStrict)
-- mark each binder with its strictness
#ifndef OMIT_STRANAL_STATS
#endif
in
-- possibly show what we decided about strictness...
- (if switch_chker D_dump_stranal
+ (if opt_D_dump_stranal
then pprTrace "Strictness:\n" (ppAboves (
- map (pprCoreBinding PprDebug pprBigCoreBinder pprBigCoreBinder ppr) binds_w_strictness))
+ map (pprCoreBinding PprDebug) binds_w_strictness))
else id
)
-- possibly show how many things we marked as demanded...
- ((if switch_chker D_simplifier_stats
+ ((if opt_D_simplifier_stats
#ifndef OMIT_STRANAL_STATS
then pp_stats sa_stats
#else
-- create worker/wrappers, and mark binders with their
-- "strictness info" [which encodes their
-- worker/wrapper-ness]
- (workersAndWrappers binds_w_strictness us switch_chker))
+ (workersAndWrappers binds_w_strictness us))
#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)
+ (ppBesides [ppPStr SLIT("Lambda vars: "), ppInt IBOX(dlam), ppChar '/', ppInt IBOX(tlam),
+ ppPStr SLIT("; Case vars: "), ppInt IBOX(dc), ppChar '/', ppInt IBOX(tc),
+ ppPStr SLIT("; Let vars: "), ppInt IBOX(dlet), ppChar '/', ppInt IBOX(tlet)
])
#endif
\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 :: StrAnalFlags -> [CoreBinding] -> [CoreBinding] -- exported
+sa_top_binds :: StrAnalFlags -> [CoreBinding] -> SaM [CoreBinding] -- not exported
saTopBinds strflags binds
#ifndef OMIT_STRANAL_STATS
\begin{code}
saTopBind :: StrictEnv -> AbsenceEnv
- -> PlainCoreBinding
- -> SaM (StrictEnv, AbsenceEnv, PlainCoreBinding)
+ -> CoreBinding
+ -> SaM (StrictEnv, AbsenceEnv, CoreBinding)
-saTopBind str_env abs_env (CoNonRec binder rhs)
+saTopBind str_env abs_env (NonRec binder rhs)
= saExpr str_env abs_env rhs `thenSa` \ new_rhs ->
let
strflags = getStrAnalFlags str_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
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
-- 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 = zipWith4Equal "saTopBind" (addStrictnessInfoToId strflags)
+ str_rhss abs_rhss binders rhss
in
mapSa (saExpr 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)
\end{code}
%************************************************************************
environment.
\begin{code}
-saExpr :: StrictEnv -> AbsenceEnv -> PlainCoreExpr -> SaM PlainCoreExpr
+saExpr :: StrictEnv -> AbsenceEnv -> CoreExpr -> SaM CoreExpr
-saExpr _ _ e@(CoVar _) = returnSa e
-saExpr _ _ e@(CoLit _) = returnSa e
-saExpr _ _ e@(CoCon _ _ _) = returnSa e
-saExpr _ _ e@(CoPrim _ _ _) = returnSa e
+saExpr _ _ e@(Var _) = returnSa e
+saExpr _ _ e@(Lit _) = returnSa e
+saExpr _ _ e@(Con _ _) = returnSa e
+saExpr _ _ e@(Prim _ _) = returnSa e
-saExpr str_env abs_env (CoLam args body)
+saExpr str_env abs_env (Lam (ValBinder arg) body)
= saExpr str_env abs_env body `thenSa` \ new_body ->
let
- new_args = addDemandInfoToIds str_env abs_env body args
+ new_arg = addDemandInfoToId str_env abs_env body arg
in
- tickLambdas new_args `thenSa_` -- stats
- returnSa (CoLam new_args new_body)
+ tickLambda new_arg `thenSa_` -- stats
+ returnSa (Lam (ValBinder new_arg) new_body)
-saExpr str_env abs_env (CoTyLam ty expr)
+saExpr str_env abs_env (Lam other_binder expr)
= saExpr str_env abs_env expr `thenSa` \ new_expr ->
- returnSa (CoTyLam ty new_expr)
+ returnSa (Lam other_binder new_expr)
-saExpr str_env abs_env (CoApp fun arg)
+saExpr str_env abs_env (App fun arg)
= saExpr str_env abs_env fun `thenSa` \ new_fun ->
- returnSa (CoApp new_fun arg)
+ returnSa (App new_fun arg)
-saExpr str_env abs_env (CoTyApp expr ty)
+saExpr str_env abs_env (SCC cc expr)
= saExpr str_env abs_env expr `thenSa` \ new_expr ->
- returnSa (CoTyApp new_expr ty)
+ returnSa (SCC cc new_expr)
-saExpr str_env abs_env (CoSCC cc expr)
+saExpr str_env abs_env (Coerce c ty expr)
= saExpr str_env abs_env expr `thenSa` \ new_expr ->
- returnSa (CoSCC cc new_expr)
+ returnSa (Coerce c ty new_expr)
-saExpr str_env abs_env (CoCase expr (CoAlgAlts alts deflt))
+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 (CoCase new_expr (CoAlgAlts new_alts new_deflt))
+ returnSa (Case new_expr (AlgAlts new_alts new_deflt))
where
sa_alt (con, binders, rhs)
= saExpr str_env abs_env rhs `thenSa` \ new_rhs ->
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 (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 (CoCase new_expr (CoPrimAlts new_alts new_deflt))
+ 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 (CoLet (CoNonRec binder rhs) body)
+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 ->
let
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
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)
+ returnSa (Let (NonRec new_binder new_rhs) new_body)
-saExpr str_env abs_env (CoLet (CoRec pairs) body)
+saExpr str_env abs_env (Let (Rec pairs) body)
= let
strflags = getStrAnalFlags str_env
(binders,rhss) = unzip pairs
mapSa (saExpr 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
+ improved_binders = zipWith4Equal "saExpr" (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)
+ returnSa (Let (Rec new_pairs) new_body)
where
launder me = {-still-} me
\end{code}
\begin{code}
-saDefault str_env abs_env CoNoDefault = returnSa CoNoDefault
+saDefault str_env abs_env NoDefault = returnSa NoDefault
-saDefault str_env abs_env (CoBindDefault bdr rhs)
+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 (CoBindDefault new_bdr new_rhs)
+ returnSa (BindDefault new_bdr new_rhs)
\end{code}
tell how many args could safely be grabbed.
\begin{code}
-addStrictnessInfoToId
+addStrictnessInfoToId
:: StrAnalFlags
-> AbsVal -- Abstract strictness value
-> AbsVal -- Ditto absence
-> Id -- The id
- -> PlainCoreExpr -- Its RHS
+ -> CoreExpr -- 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
- }
+
+ | isBot str_val
+ = binder `addIdStrictness` mkBottomStrictnessInfo
+
+ | otherwise
+ = case (collectBinders body) of
+ (_, _, [], rhs) -> binder
+ (_, _, lambda_bounds, rhs) -> binder `addIdStrictness`
+ mkStrictnessInfo strictness Nothing
+ where
+ tys = map idType lambda_bounds
+ strictness = findStrictness strflags tys str_val abs_val
\end{code}
\begin{code}
-addDemandInfoToId :: StrictEnv -> AbsenceEnv
- -> PlainCoreExpr -- The scope of the id
- -> Id
+addDemandInfoToId :: 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]
+addDemandInfoToIds :: StrictEnv -> AbsenceEnv -> CoreExpr -> [Id] -> [Id]
-addDemandInfoToIds str_env abs_env expr binders
+addDemandInfoToIds str_env abs_env expr binders
= map (addDemandInfoToId str_env abs_env expr) binders
\end{code}
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 :: [Id] -> 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)) ->
+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) }
tickCases vars (SaStats tlam dlam tc dc tlet dlet)
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-}
projects / ghc-hetmet.git / blobdiff