Semantique analyser) was written by Andy Gill.
\begin{code}
-#include "HsVersions.h"
-
-module StrictAnal ( saWwTopBinds, saTopBinds ) where
+module StrictAnal ( saWwTopBinds ) where
-IMP_Ubiq(){-uitous-}
+#include "HsVersions.h"
-import CmdLineOpts ( opt_AllStrict, opt_NumbersStrict,
- opt_D_dump_stranal, opt_D_simplifier_stats
+import CmdLineOpts ( opt_D_dump_stranal, opt_D_simplifier_stats
)
import CoreSyn
-import Id ( idType, addIdStrictness, isWrapperId,
+import Id ( idType, addIdStrictness,
getIdDemandInfo, addIdDemandInfo,
- GenId{-instance Outputable-}
+ Id
)
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 PprCore ( pprCoreBinding )
import SaAbsInt
import SaLib
-import TyVar ( GenTyVar{-instance Eq-} )
import WorkWrap -- "back-end" of strictness analyser
import Unique ( Unique{-instance Eq -} )
-import Util ( zipWith4Equal, pprTrace, panic )
+import UniqSupply ( UniqSupply )
+import Util ( zipWith4Equal )
+import Outputable
\end{code}
%************************************************************************
saWwTopBinds us binds
= let
- strflags = (opt_AllStrict, opt_NumbersStrict)
-- mark each binder with its strictness
#ifndef OMIT_STRANAL_STATS
(binds_w_strictness, sa_stats)
- = sa_top_binds strflags binds nullSaStats
+ = saTopBinds binds nullSaStats
#else
binds_w_strictness
- = sa_top_binds strflags binds
+ = saTopBindsBinds binds
#endif
in
-- possibly show what we decided about strictness...
(if opt_D_dump_stranal
- then pprTrace "Strictness:\n" (ppAboves (
- map (pprCoreBinding PprDebug) binds_w_strictness))
+ then pprTrace "Strictness:\n" (vcat (
+ map (pprCoreBinding) binds_w_strictness))
else id
)
-- possibly show how many things we marked as demanded...
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)
+ (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)
])
#endif
\end{code}
@AbsValEnv@ maps an @Id@ to its @AbsVal@).
\begin{code}
-saTopBinds :: StrAnalFlags -> [CoreBinding] -> [CoreBinding] -- exported
-sa_top_binds :: StrAnalFlags -> [CoreBinding] -> SaM [CoreBinding] -- not exported
+saTopBinds :: [CoreBinding] -> SaM [CoreBinding] -- 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
saTopBind str_env abs_env (NonRec binder rhs)
= saExpr 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
new_binder
= addStrictnessInfoToId
- strflags
widened_str_rhs widened_abs_rhs
binder
rhs
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 = zipWith4Equal "saTopBind" (addStrictnessInfoToId strflags)
+ new_binders = zipWith4Equal "saTopBind" addStrictnessInfoToId
str_rhss abs_rhss binders rhss
in
mapSa (saExpr new_str_env new_abs_env) rhss `thenSa` \ new_rhss ->
= saExpr str_env abs_env fun `thenSa` \ new_fun ->
returnSa (App new_fun 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)
-
-saExpr str_env abs_env (Coerce c ty expr)
- = saExpr str_env abs_env expr `thenSa` \ new_expr ->
- returnSa (Coerce c ty new_expr)
+ returnSa (Note note new_expr)
saExpr str_env abs_env (Case expr (AlgAlts alts deflt))
= saExpr str_env abs_env expr `thenSa` \ new_expr ->
= -- Analyse the RHS in the environment at hand
saExpr str_env abs_env rhs `thenSa` \ new_rhs ->
let
- strflags = getStrAnalFlags str_env
-
-- Bind this binder to the abstract value of the RHS; analyse
-- the body of the `let' in the extended environment.
str_rhs_val = absEval StrAnal rhs str_env
-- 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
saExpr 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
-- deciding that y is absent, which is plain wrong!
-- It's much easier simply not to do this.
- improved_binders = zipWith4Equal "saExpr" (addStrictnessInfoToId strflags)
+ improved_binders = zipWith4Equal "saExpr" addStrictnessInfoToId
str_vals abs_vals binders rhss
whiter_than_white_binders = launder improved_binders
\begin{code}
addStrictnessInfoToId
- :: StrAnalFlags
- -> AbsVal -- Abstract strictness value
+ :: AbsVal -- Abstract strictness value
-> AbsVal -- Ditto absence
-> Id -- The id
-> CoreExpr -- Its RHS
-> Id -- Augmented with strictness
-addStrictnessInfoToId strflags str_val abs_val binder body
+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
+ (_, [], rhs) -> binder
+ (_, lambda_bounds, rhs) -> binder `addIdStrictness`
+ mkStrictnessInfo strictness False
where
tys = map idType lambda_bounds
- strictness = findStrictness strflags tys str_val abs_val
+ strictness = findStrictness tys str_val abs_val
\end{code}
\begin{code}
projects / ghc-hetmet.git / blobdiff