X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fstranal%2FStrictAnal.lhs;h=1bc847424ad7d341cf701bac5c383da1854b5f61;hb=438596897ebbe25a07e1c82085cfbc5bdb00f09e;hp=5e8396604672f28c3f19c6eaa8b9889bbc930112;hpb=10521d8418fd3a1cf32882718b5bd28992db36fd;p=ghc-hetmet.git diff --git a/ghc/compiler/stranal/StrictAnal.lhs b/ghc/compiler/stranal/StrictAnal.lhs index 5e83966..1bc8474 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,28 @@ 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 ( saWwTopBinds ) 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 ( opt_D_dump_stranal, opt_D_simplifier_stats, opt_D_verbose_core2core ) +import CoreSyn +import Id ( idType, setIdStrictness, + getIdDemandInfo, setIdDemandInfo, + Id ) -import IdEnv -import IdInfo -import PlainCore +import IdInfo ( mkStrictnessInfo, mkBottomStrictnessInfo ) +import CoreLint ( beginPass, endPass ) +import ErrUtils ( dumpIfSet ) import SaAbsInt import SaLib -import SplitUniq -import Unique -import Util +import Demand ( isStrict ) import WorkWrap -- "back-end" of strictness analyser -import WwLib ( WwM(..) ) +import UniqSupply ( UniqSupply ) +import Util ( zipWith4Equal ) +import Outputable \end{code} - %************************************************************************ %* * \subsection[Thoughts]{Random thoughts} @@ -49,12 +44,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 @@ -81,52 +76,29 @@ Alas and alack. %************************************************************************ \begin{code} -saWwTopBinds :: SplitUniqSupply - -> (GlobalSwitch -> Bool) - -> [PlainCoreBinding] - -> [PlainCoreBinding] +saWwTopBinds :: UniqSupply + -> [CoreBind] + -> IO [CoreBind] -saWwTopBinds us switch_chker binds - = let - strflags = (switch_chker AllStrict, switch_chker NumbersStrict) +saWwTopBinds us binds + = do { + beginPass "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 opt_D_simplifier_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 + + -- Create worker/wrappers, and mark binders with their + -- "strictness info" [which encodes their worker/wrapper-ness] + let { binds' = workersAndWrappers us binds_w_strictness }; + + endPass "Strictness analysis" (opt_D_dump_stranal || opt_D_verbose_core2core) binds' + } \end{code} %************************************************************************ @@ -151,19 +123,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 strflags binds -#ifndef OMIT_STRANAL_STATS - = fst (sa_top_binds strflags binds nullSaStats) -#else - = sa_top_binds strflags binds -#endif +saTopBinds :: [CoreBind] -> SaM [CoreBind] -- not exported -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,25 +145,22 @@ 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) +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 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 widened_str_rhs widened_abs_rhs binder rhs @@ -209,25 +170,24 @@ saTopBind str_env abs_env (CoNonRec binder rhs) 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 = zipWith4Equal "saTopBind" addStrictnessInfoToId + 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} %************************************************************************ @@ -240,67 +200,49 @@ saTopBind str_env abs_env (CoRec pairs) 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@(Con _ _) = returnSa e +saExpr _ _ e@(Type _) = returnSa e -saExpr str_env abs_env (CoLam args body) - = saExpr str_env abs_env body `thenSa` \ new_body -> - let - new_args = addDemandInfoToIds str_env abs_env body args - in - tickLambdas new_args `thenSa_` -- stats - returnSa (CoLam new_args new_body) +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 (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 (App 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 arg `thenSa` \ new_arg -> + returnSa (App new_fun new_arg) -saExpr str_env abs_env (CoSCC cc expr) +saExpr str_env abs_env (Note note expr) = saExpr str_env abs_env expr `thenSa` \ new_expr -> - returnSa (CoSCC cc new_expr) + returnSa (Note note 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)) +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 (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 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 - -- 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 @@ -309,25 +251,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 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 str_vals = fixpoint StrAnal binders rhss str_env abs_vals = fixpoint AbsAnal binders rhss abs_env @@ -339,7 +280,7 @@ saExpr str_env abs_env (CoLet (CoRec pairs) body) 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... @@ -350,28 +291,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 + improved_binders = zipWith4Equal "saExpr" addStrictnessInfoToId + str_vals abs_vals binders rhss - new_pairs = whiter_than_white_binders `zip` new_rhss + new_pairs = improved_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 - -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 - in - tickCases [new_bdr] `thenSa_` -- stats - returnSa (CoBindDefault new_bdr new_rhs) + returnSa (Let (Rec new_pairs) new_body) \end{code} @@ -393,44 +318,43 @@ 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 + -> 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 - } +addStrictnessInfoToId str_val abs_val binder body + + | isBot str_val + = binder `setIdStrictness` mkBottomStrictnessInfo + + | otherwise + = case (collectTyAndValBinders body) of + (_, [], rhs) -> binder + (_, lambda_bounds, rhs) -> binder `setIdStrictness` + mkStrictnessInfo strictness False + where + tys = map idType lambda_bounds + strictness = findStrictness 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)) + = 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 -> 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} @@ -453,15 +377,13 @@ 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,8 +398,8 @@ 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)) -> +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) @@ -489,11 +411,19 @@ tickLet var (SaStats tlam dlam tc dc tlet dlet) ((), 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 @@ -504,9 +434,9 @@ 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-}