X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fstranal%2FStrictAnal.lhs;h=242a94707430685b8bda5b881909ae633fad4ad3;hb=28a464a75e14cece5db40f2765a29348273ff2d2;hp=8eaecfa202878a1da3b9aa32a8d0695fd9178090;hpb=2c8f04b5b883db74f449dfc8c224929fe28b027d;p=ghc-hetmet.git diff --git a/ghc/compiler/stranal/StrictAnal.lhs b/ghc/compiler/stranal/StrictAnal.lhs index 8eaecfa..242a947 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-1996 +% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998 % \section[StrictAnal]{``Simple'' Mycroft-style strictness analyser} @@ -7,28 +7,30 @@ The original version(s) of all strictness-analyser code (except the Semantique analyser) was written by Andy Gill. \begin{code} -module StrictAnal ( saWwTopBinds ) where +#ifndef OLD_STRICTNESS +module StrictAnal ( ) where + +#else + +module StrictAnal ( saBinds ) where #include "HsVersions.h" -import CmdLineOpts ( opt_D_dump_stranal, opt_D_simplifier_stats - ) +import DynFlags ( DynFlags, DynFlag(..) ) import CoreSyn -import Id ( idType, addIdStrictness, - getIdDemandInfo, addIdDemandInfo, +import Id ( setIdStrictness, setInlinePragma, + idDemandInfo, setIdDemandInfo, isBottomingId, Id ) -import IdInfo ( mkStrictnessInfo, mkBottomStrictnessInfo, - mkDemandInfo, willBeDemanded, DemandInfo - ) -import PprCore ( pprCoreBinding ) +import CoreLint ( showPass, endPass ) +import ErrUtils ( dumpIfSet_dyn ) import SaAbsInt import SaLib -import WorkWrap -- "back-end" of strictness analyser -import Unique ( Unique{-instance Eq -} ) -import UniqSupply ( UniqSupply ) -import Util ( zipWith4Equal ) +import Demand ( Demand, wwStrict, isStrict, isLazy ) +import Util ( zipWith3Equal, stretchZipWith, compareLength ) +import BasicTypes ( Activation( NeverActive ) ) import Outputable +import FastTypes \end{code} %************************************************************************ @@ -77,51 +79,28 @@ Alas and alack. %* * %************************************************************************ -\begin{code} -saWwTopBinds :: UniqSupply - -> [CoreBinding] - -> [CoreBinding] +@saBinds@ decorates bindings with strictness info. A later +worker-wrapper pass can use this info to create wrappers and +strict workers. -saWwTopBinds us binds - = let +\begin{code} +saBinds :: DynFlags -> [CoreBind] -> IO [CoreBind] +saBinds dflags binds + = do { + showPass dflags "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) 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_dyn dflags 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 dflags "Strictness analysis" Opt_D_dump_stranal + binds_w_strictness + } \end{code} %************************************************************************ @@ -146,7 +125,7 @@ environment which maps @Id@s to their abstract values (i.e., an @AbsValEnv@ maps an @Id@ to its @AbsVal@). \begin{code} -saTopBinds :: [CoreBinding] -> SaM [CoreBinding] -- not exported +saTopBinds :: [CoreBind] -> SaM [CoreBind] -- not exported saTopBinds binds = let @@ -168,11 +147,11 @@ be used; we can't turn top-level @let@s into @case@s. \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 minDemand str_env abs_env rhs `thenSa` \ new_rhs -> let str_rhs = absEval StrAnal rhs str_env abs_rhs = absEval AbsAnal rhs abs_env @@ -183,10 +162,9 @@ saTopBind str_env abs_env (NonRec binder rhs) -- See notes on Let case in SaAbsInt.lhs new_binder - = addStrictnessInfoToId + = addStrictnessInfoToTopId widened_str_rhs widened_abs_rhs binder - rhs -- Augment environments with a mapping of the -- binder to its abstract values, computed by absEval @@ -203,14 +181,25 @@ saTopBind str_env abs_env (Rec 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 = zipWith4Equal "saTopBind" addStrictnessInfoToId - str_rhss abs_rhss binders rhss + new_binders = zipWith3Equal "saTopBind" addStrictnessInfoToTopId + str_rhss abs_rhss binders in - mapSa (saExpr new_str_env new_abs_env) rhss `thenSa` \ new_rhss -> + mapSa (saExpr minDemand 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, Rec new_pairs) + +-- Hack alert! +-- Top level divergent bindings are marked NOINLINE +-- This avoids fruitless inlining of top level error functions +addStrictnessInfoToTopId str_val abs_val bndr + = if isBottomingId new_id then + new_id `setInlinePragma` NeverActive + else + new_id + where + new_id = addStrictnessInfoToId str_val abs_val bndr \end{code} %************************************************************************ @@ -223,61 +212,86 @@ saTopBind str_env abs_env (Rec pairs) environment. \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 :: Demand -> StrictEnv -> AbsenceEnv -> CoreExpr -> SaM CoreExpr + -- The demand is the least demand we expect on the + -- expression. WwStrict is the least, because we're only + -- interested in the expression at all if it's being evaluated, + -- but the demand may be more. E.g. + -- f E + -- where f has strictness u(LL), will evaluate E with demand u(LL) + +minDemand = wwStrict +minDemands = repeat minDemand + +-- When we find an application, do the arguments +-- with demands gotten from the function +saApp str_env abs_env (fun, args) + = sequenceSa sa_args `thenSa` \ args' -> + saExpr minDemand str_env abs_env fun `thenSa` \ fun' -> + returnSa (mkApps fun' args') + where + arg_dmds = case fun of + Var var -> case lookupAbsValEnv str_env var of + Just (AbsApproxFun ds _) + | compareLength ds args /= LT + -- 'ds' is at least as long as 'args'. + -> ds ++ minDemands + other -> minDemands + other -> minDemands + + sa_args = stretchZipWith isTypeArg (error "saApp:dmd") + sa_arg args arg_dmds + -- The arg_dmds are for value args only, we need to skip + -- over the type args when pairing up with the demands + -- Hence the stretchZipWith + + sa_arg arg dmd = saExpr dmd' str_env abs_env arg + where + -- Bring arg demand up to minDemand + dmd' | isLazy dmd = minDemand + | otherwise = dmd + +saExpr _ _ _ e@(Var _) = returnSa e +saExpr _ _ _ e@(Lit _) = returnSa e +saExpr _ _ _ e@(Type _) = returnSa e + +saExpr dmd 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 minDemand str_env abs_env body `thenSa` \ new_body -> + returnSa (Lam bndr new_body) + +saExpr dmd str_env abs_env e@(App fun arg) + = saApp str_env abs_env (collectArgs e) + +saExpr dmd str_env abs_env (Note note expr) + = saExpr dmd str_env abs_env expr `thenSa` \ new_expr -> + returnSa (Note note new_expr) -saExpr str_env abs_env (Lam (ValBinder arg) body) - = saExpr str_env abs_env body `thenSa` \ new_body -> +saExpr dmd str_env abs_env (Case expr case_bndr alts) + = saExpr minDemand str_env abs_env expr `thenSa` \ new_expr -> + mapSa sa_alt alts `thenSa` \ new_alts -> let - new_arg = addDemandInfoToId str_env abs_env body arg + new_case_bndr = addDemandInfoToCaseBndr dmd str_env abs_env alts case_bndr 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 (App fun arg) - = saExpr str_env abs_env fun `thenSa` \ new_fun -> - returnSa (App new_fun arg) - -saExpr str_env abs_env (Note note expr) - = saExpr str_env abs_env expr `thenSa` \ 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 -> - 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)) + returnSa (Case new_expr new_case_bndr new_alts) where sa_alt (con, binders, rhs) - = saExpr str_env abs_env rhs `thenSa` \ new_rhs -> + = saExpr dmd 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 dmd 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) +saExpr dmd 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 + -- Find the demand on the RHS + rhs_dmd = findDemand dmd str_env abs_env body binder + -- 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 @@ -295,14 +309,14 @@ saExpr str_env abs_env (Let (NonRec binder rhs) body) -- to record DemandInfo/StrictnessInfo in the binder. new_binder = addStrictnessInfoToId widened_str_rhs widened_abs_rhs - (addDemandInfoToId str_env abs_env body binder) - rhs + (binder `setIdDemandInfo` rhs_dmd) in - tickLet new_binder `thenSa_` -- stats - saExpr new_str_env new_abs_env body `thenSa` \ new_body -> + tickLet new_binder `thenSa_` -- stats + saExpr rhs_dmd str_env abs_env rhs `thenSa` \ new_rhs -> + saExpr dmd new_str_env new_abs_env body `thenSa` \ new_body -> returnSa (Let (NonRec new_binder new_rhs) new_body) -saExpr str_env abs_env (Let (Rec pairs) body) +saExpr dmd str_env abs_env (Let (Rec pairs) body) = let (binders,rhss) = unzip pairs str_vals = fixpoint StrAnal binders rhss str_env @@ -311,10 +325,9 @@ saExpr str_env abs_env (Let (Rec pairs) body) new_str_env = growAbsValEnvList str_env (binders `zip` str_vals) new_abs_env = growAbsValEnvList abs_env (binders `zip` abs_vals) in - saExpr new_str_env new_abs_env body `thenSa` \ new_body -> - mapSa (saExpr new_str_env new_abs_env) rhss `thenSa` \ new_rhss -> + saExpr dmd new_str_env new_abs_env body `thenSa` \ new_body -> + mapSa (saExpr minDemand 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 Rec! -- a) it's useless: we can't do let-to-case -- b) it's incorrect. Consider @@ -326,28 +339,12 @@ saExpr str_env abs_env (Let (Rec pairs) body) -- deciding that y is absent, which is plain wrong! -- It's much easier simply not to do this. - improved_binders = zipWith4Equal "saExpr" addStrictnessInfoToId - str_vals abs_vals binders rhss - - whiter_than_white_binders = launder improved_binders + improved_binders = zipWith3Equal "saExpr" addStrictnessInfoToId + str_vals abs_vals 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} @@ -373,37 +370,23 @@ addStrictnessInfoToId :: AbsVal -- Abstract strictness value -> AbsVal -- Ditto absence -> Id -- The id - -> CoreExpr -- Its RHS -> 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 False - where - tys = map idType lambda_bounds - strictness = findStrictness tys str_val abs_val +addStrictnessInfoToId str_val abs_val binder + = binder `setIdStrictness` findStrictness binder str_val abs_val \end{code} \begin{code} -addDemandInfoToId :: StrictEnv -> AbsenceEnv +addDemandInfoToId :: Demand -> 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 -> CoreExpr -> [Id] -> [Id] +addDemandInfoToId dmd str_env abs_env expr binder + = binder `setIdDemandInfo` (findDemand dmd str_env abs_env expr binder) -addDemandInfoToIds str_env abs_env expr binders - = map (addDemandInfoToId str_env abs_env expr) binders +addDemandInfoToCaseBndr dmd str_env abs_env alts binder + = binder `setIdDemandInfo` (findDemandAlts dmd str_env abs_env alts binder) \end{code} %************************************************************************ @@ -414,12 +397,12 @@ addDemandInfoToIds str_env abs_env expr binders \begin{code} data SaStats - = SaStats FAST_INT FAST_INT -- total/marked-demanded lambda-bound - FAST_INT FAST_INT -- total/marked-demanded case-bound - FAST_INT FAST_INT -- total/marked-demanded let-bound + = SaStats FastInt FastInt -- total/marked-demanded lambda-bound + FastInt FastInt -- total/marked-demanded case-bound + FastInt FastInt -- total/marked-demanded let-bound -- (excl. top-level; excl. letrecs) -nullSaStats = SaStats ILIT(0) ILIT(0) ILIT(0) ILIT(0) ILIT(0) ILIT(0) +nullSaStats = SaStats (_ILIT 0) (_ILIT 0) (_ILIT 0) (_ILIT 0) (_ILIT 0) (_ILIT 0) thenSa :: SaM a -> (a -> SaM b) -> SaM b thenSa_ :: SaM a -> SaM b -> SaM b @@ -430,7 +413,7 @@ returnSa :: a -> SaM a {-# INLINE returnSa #-} tickLambda :: Id -> SaM () -tickCases :: [Id] -> SaM () +tickCases :: [CoreBndr] -> SaM () tickLet :: Id -> SaM () #ifndef OMIT_STRANAL_STATS @@ -447,24 +430,38 @@ thenSa_ expr cont stats returnSa x stats = (x, stats) 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) } + = case (tick_demanded var (0,0)) of { (totB, demandedB) -> + let tot = iUnbox totB ; demanded = iUnbox demandedB + in + ((), SaStats (tlam +# tot) (dlam +# demanded) tc dc tlet dlet) } tickCases vars (SaStats tlam dlam tc dc tlet dlet) - = case (foldr tick_demanded (0,0) vars) of { (IBOX(tot), IBOX(demanded)) -> - ((), SaStats tlam dlam (tc _ADD_ tot) (dc _ADD_ demanded) tlet dlet) } + = case (foldr tick_demanded (0,0) vars) of { (totB, demandedB) -> + let tot = iUnbox totB ; demanded = iUnbox demandedB + in + ((), SaStats tlam dlam (tc +# tot) (dc +# demanded) tlet dlet) } tickLet var (SaStats tlam dlam tc dc tlet dlet) - = case (tick_demanded var (0,0)) of { (IBOX(tot),IBOX(demanded)) -> - ((), SaStats tlam dlam tc dc (tlet _ADD_ tot) (dlet _ADD_ demanded)) } + = case (tick_demanded var (0,0)) of { (totB, demandedB) -> + let tot = iUnbox totB ; demanded = iUnbox demandedB + in + ((), SaStats tlam dlam tc dc (tlet +# tot) (dlet +# demanded)) } tick_demanded var (tot, demanded) + | isTyVar var = (tot, demanded) + | otherwise = (tot + 1, - if (willBeDemanded (getIdDemandInfo var)) + if (isStrict (idDemandInfo var)) then demanded + 1 else demanded) -#else {-OMIT_STRANAL_STATS-} +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 @@ -478,13 +475,20 @@ 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-} +#endif /* OMIT_STRANAL_STATS */ mapSa :: (a -> SaM b) -> [a] -> SaM [b] mapSa f [] = returnSa [] -mapSa f (x:xs) - = f x `thenSa` \ r -> - mapSa f xs `thenSa` \ rs -> - returnSa (r:rs) +mapSa f (x:xs) = f x `thenSa` \ r -> + mapSa f xs `thenSa` \ rs -> + returnSa (r:rs) + +sequenceSa :: [SaM a] -> SaM [a] +sequenceSa [] = returnSa [] +sequenceSa (m:ms) = m `thenSa` \ r -> + sequenceSa ms `thenSa` \ rs -> + returnSa (r:rs) + +#endif /* OLD_STRICTNESS */ \end{code}