X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fstranal%2FStrictAnal.lhs;h=5013b29392348ed3e439eb41d1108001bdc66aca;hb=1fb1ab5d53a09607e7f6d2450806760688396387;hp=5e8396604672f28c3f19c6eaa8b9889bbc930112;hpb=10521d8418fd3a1cf32882718b5bd28992db36fd;p=ghc-hetmet.git diff --git a/ghc/compiler/stranal/StrictAnal.lhs b/ghc/compiler/stranal/StrictAnal.lhs index 5e83966..5013b29 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-1996 % \section[StrictAnal]{``Simple'' Mycroft-style strictness analyser} @@ -11,29 +11,31 @@ Semantique analyser) was written by Andy Gill. 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} @@ -49,12 +51,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,14 +83,13 @@ Alas and alack. %************************************************************************ \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 @@ -100,13 +101,13 @@ saWwTopBinds us switch_chker binds #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 @@ -117,14 +118,14 @@ saWwTopBinds us switch_chker binds -- 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} @@ -151,8 +152,8 @@ 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 :: StrAnalFlags -> [CoreBinding] -> [CoreBinding] -- exported +sa_top_binds :: StrAnalFlags -> [CoreBinding] -> SaM [CoreBinding] -- not exported saTopBinds strflags binds #ifndef OMIT_STRANAL_STATS @@ -181,10 +182,10 @@ be used; we can't turn top-level @let@s into @case@s. \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 @@ -195,7 +196,7 @@ saTopBind str_env abs_env (CoNonRec binder rhs) 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 @@ -209,9 +210,9 @@ 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 @@ -220,14 +221,14 @@ saTopBind str_env abs_env (CoRec 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} %************************************************************************ @@ -240,42 +241,42 @@ 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@(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 -> @@ -285,17 +286,17 @@ saExpr str_env abs_env (CoCase expr (CoAlgAlts alts deflt)) 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 @@ -309,7 +310,7 @@ 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 @@ -323,9 +324,9 @@ saExpr str_env abs_env (CoLet (CoNonRec binder rhs) body) 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 @@ -339,7 +340,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 +351,28 @@ 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 + 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} @@ -393,44 +394,41 @@ A better idea might be to have some kind of arity analysis to 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} @@ -453,15 +451,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 :: [Id] -> SaM () +tickLet :: Id -> SaM () #ifndef OMIT_STRANAL_STATS type SaM a = SaStats -> (a, SaStats) @@ -476,8 +472,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) @@ -504,9 +500,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-}