module StrictAnal ( saWwTopBinds, saTopBinds ) where
-import Id ( addIdDemandInfo, isWrapperId, addIdStrictness,
- idType, getIdDemandInfo
+IMP_Ubiq(){-uitous-}
+
+import CmdLineOpts ( opt_AllStrict, opt_NumbersStrict,
+ opt_D_dump_stranal, opt_D_simplifier_stats
+ )
+import CoreSyn
+import Id ( idType, addIdStrictness, isWrapperId,
+ getIdDemandInfo, addIdDemandInfo,
+ GenId{-instance Outputable-}
)
-import IdInfo
+import IdInfo ( mkStrictnessInfo, mkBottomStrictnessInfo,
+ mkDemandInfo, willBeDemanded, DemandInfo
+ )
+import PprCore ( pprCoreBinding, pprBigCoreBinder )
+import PprStyle ( PprStyle(..) )
+import PprType ( GenType{-instance Outputable-}, GenTyVar{-ditto-} )
+import Pretty ( ppBesides, ppStr, ppInt, ppChar, ppAboves )
import SaAbsInt
import SaLib
-import UniqSupply
-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}
\begin{code}
saWwTopBinds :: UniqSupply
- -> (GlobalSwitch -> Bool)
-> [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)
-- 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 = zipWith4Equal (addStrictnessInfoToId strflags)
+ 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 ->
\begin{code}
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@(Var _) = returnSa e
+saExpr _ _ e@(Lit _) = returnSa e
+saExpr _ _ e@(Con _ _) = returnSa e
+saExpr _ _ e@(Prim _ _) = returnSa e
-saExpr str_env abs_env (Lam arg body)
+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 new_arg new_body)
+ 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 (App fun arg)
= saExpr str_env abs_env fun `thenSa` \ new_fun ->
returnSa (App 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 (SCC cc expr)
= saExpr str_env abs_env expr `thenSa` \ new_expr ->
returnSa (SCC cc 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 ->
-- deciding that y is absent, which is plain wrong!
-- It's much easier simply not to do this.
- improved_binders = zipWith4Equal (addStrictnessInfoToId strflags)
+ improved_binders = zipWith4Equal "saExpr" (addStrictnessInfoToId strflags)
str_vals abs_vals binders rhss
whiter_than_white_binders = launder improved_binders
-> Id -- Augmented with strictness
addStrictnessInfoToId strflags str_val abs_val binder body
- = if isWrapperId binder then
- binder -- Avoid clobbering existing strictness info
+
+{- SCHEDULED FOR NUKING
+ | isWrapperId binder
+ = 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 idType 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 { (_, _, lambda_bounds, rhs) ->
+ let
+ tys = map idType lambda_bounds
+ strictness = findStrictness strflags tys str_val abs_val
+ in
+ binder `addIdStrictness` mkStrictnessInfo strictness Nothing
+ }
\end{code}
\begin{code}
{-# INLINE thenSa_ #-}
{-# INLINE returnSa #-}
-tickLambda :: [Id] -> SaM ()
+tickLambda :: Id -> SaM ()
tickCases :: [Id] -> SaM ()
tickLet :: Id -> SaM ()
returnSa x stats = (x, stats)
tickLambda var (SaStats tlam dlam tc dc tlet dlet)
- = case (tick_demanded (0,0) var) of { (IBOX(tot), IBOX(demanded)) ->
+ = 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)
projects / ghc-hetmet.git / blobdiff