X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplCore%2FBinderInfo.lhs;h=1623bcd702482cfab01b4fb285371e0886c90057;hb=ff755dd9a0a0ad2f106c323852553ea247f16141;hp=75155a6b745d008766a00c5a06626af54bfb7e62;hpb=3effaf6c3e2f4da7a8808b190074d492b62b2f7e;p=ghc-hetmet.git diff --git a/ghc/compiler/simplCore/BinderInfo.lhs b/ghc/compiler/simplCore/BinderInfo.lhs index 75155a6..1623bcd 100644 --- a/ghc/compiler/simplCore/BinderInfo.lhs +++ b/ghc/compiler/simplCore/BinderInfo.lhs @@ -1,5 +1,5 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % %************************************************************************ %* * @@ -8,30 +8,25 @@ %************************************************************************ \begin{code} -#include "HsVersions.h" - module BinderInfo ( - BinderInfo(..), - FunOrArg, DuplicationDanger, InsideSCC, -- NB: all abstract (yay!) + BinderInfo, - addBinderInfo, orBinderInfo, andBinderInfo, + addBinderInfo, orBinderInfo, - argOccurrence, funOccurrence, dangerousArgOcc, noBinderInfo, - markMany, markDangerousToDup, markInsideSCC, + deadOccurrence, funOccurrence, noBinderInfo, + + markMany, markInsideLam, markInsideSCC, getBinderInfoArity, setBinderInfoArityToZero, - inlineUnconditionally, isFun, isDupDanger -- for Simon Marlow deforestation + binderInfoToOccInfo ) where -IMP_Ubiq(){-uitous-} - -import Pretty -import Util ( panic ) -#if __GLASGOW_HASKELL__ >= 202 -import Outputable -#endif +#include "HsVersions.h" +import IdInfo ( OccInfo(..), InsideLam, OneBranch, insideLam, notInsideLam, oneBranch ) +import GlaExts ( Int(..), (+#) ) +import Outputable \end{code} The @BinderInfo@ describes how a variable is used in a given scope. @@ -48,27 +43,25 @@ data BinderInfo | ManyOcc -- Everything else besides DeadCode and OneOccs - Int -- number of arguments on stack when called; this is a minimum guarantee + !Int -- number of arguments on stack when called; this is a minimum guarantee - | OneOcc -- Just one occurrence (or one each in + | SingleOcc -- Just one occurrence (or one each in -- mutually-exclusive case alts). - FunOrArg -- How it occurs - - DuplicationDanger + !InsideLam - InsideSCC + !InsideSCC - Int -- Number of mutually-exclusive case alternatives + !Int -- Number of mutually-exclusive case alternatives -- in which it occurs -- Note that we only worry about the case-alt counts - -- if the OneOcc is substitutable -- that's the only + -- if the SingleOcc is substitutable -- that's the only -- time we *use* the info; we could be more clever for -- other cases if we really had to. (WDP/PS) - Int -- number of arguments on stack when called; minimum guarantee + !Int -- number of arguments on stack when called; minimum guarantee -- In general, we are feel free to substitute unless -- (a) is in an argument position (ArgOcc) @@ -78,196 +71,95 @@ data BinderInfo -- (because the RHS will be inlined regardless of its size) -- [again, DupDanger] -data FunOrArg - = FunOcc -- An occurrence in a function position - | ArgOcc -- Other arg occurrence - - -- When combining branches of a case, only report FunOcc if - -- both branches are FunOccs - -data DuplicationDanger - = DupDanger -- Inside a non-linear lambda (that is, a lambda which - -- is sure to be instantiated only once), or inside - -- the rhs of an INLINE-pragma'd thing. Either way, - -- substituting a redex for this occurrence is - -- dangerous because it might duplicate work. - - | NoDupDanger -- It's ok; substitution won't duplicate work. - data InsideSCC = InsideSCC -- Inside an SCC; so be careful when substituting. | NotInsideSCC -- It's ok. noBinderInfo = ManyOcc 0 -- A non-committal value -\end{code} - - +\end{code} \begin{code} -isFun :: FunOrArg -> Bool -isFun FunOcc = True -isFun _ = False - -isDupDanger :: DuplicationDanger -> Bool -isDupDanger DupDanger = True -isDupDanger _ = False +binderInfoToOccInfo :: BinderInfo -> OccInfo +binderInfoToOccInfo DeadCode = IAmDead +binderInfoToOccInfo (SingleOcc in_lam NotInsideSCC n_alts _) = OneOcc in_lam (n_alts==1) +binderInfoToOccInfo other = NoOccInfo \end{code} -@inlineUnconditionally@ decides whether a let-bound thing can -definitely be inlined. - -\begin{code} -inlineUnconditionally :: Bool -> BinderInfo -> Bool - ---inlineUnconditionally ok_to_dup DeadCode = True -inlineUnconditionally ok_to_dup (OneOcc FunOcc NoDupDanger NotInsideSCC n_alt_occs _) - = n_alt_occs <= 1 || ok_to_dup - -- We [i.e., Patrick] don't mind the code explosion, - -- though. We could have a flag to limit the - -- damage, e.g., limit to M alternatives. - -inlineUnconditionally _ _ = False -\end{code} Construction ~~~~~~~~~~~~~ \begin{code} -argOccurrence, funOccurrence :: Int -> BinderInfo - -funOccurrence = OneOcc FunOcc NoDupDanger NotInsideSCC 1 -argOccurrence = OneOcc ArgOcc NoDupDanger NotInsideSCC 1 +deadOccurrence :: BinderInfo +deadOccurrence = DeadCode -markMany, markDangerousToDup, markInsideSCC :: BinderInfo -> BinderInfo +funOccurrence :: Int -> BinderInfo +funOccurrence = SingleOcc notInsideLam NotInsideSCC 1 -markMany (OneOcc _ _ _ _ ar) = ManyOcc ar -markMany (ManyOcc ar) = ManyOcc ar -markMany DeadCode = panic "markMany" +markMany, markInsideLam, markInsideSCC :: BinderInfo -> BinderInfo -markDangerousToDup (OneOcc posn _ in_scc n_alts ar) - = OneOcc posn DupDanger in_scc n_alts ar -markDangerousToDup other = other +markMany (SingleOcc _ _ _ ar) = ManyOcc ar +markMany (ManyOcc ar) = ManyOcc ar +markMany DeadCode = panic "markMany" -dangerousArgOcc = OneOcc ArgOcc DupDanger NotInsideSCC 1 0 +markInsideLam (SingleOcc _ in_scc n_alts ar) = SingleOcc insideLam in_scc n_alts ar +markInsideLam other = other -markInsideSCC (OneOcc posn dup_danger _ n_alts ar) - = OneOcc posn dup_danger InsideSCC n_alts ar -markInsideSCC other = other +markInsideSCC (SingleOcc dup_danger _ n_alts ar) = SingleOcc dup_danger InsideSCC n_alts ar +markInsideSCC other = other -addBinderInfo, orBinderInfo - :: BinderInfo -> BinderInfo -> BinderInfo +addBinderInfo, orBinderInfo :: BinderInfo -> BinderInfo -> BinderInfo addBinderInfo DeadCode info2 = info2 addBinderInfo info1 DeadCode = info1 addBinderInfo info1 info2 - = case (min (getBinderInfoArity info1) (getBinderInfoArity info2)) of - (I# i#) -> ManyOcc (I# i#) - -- ManyOcc min (getBinderInfoArity info1) (getBinderInfoArity info2)) + = ManyOcc (min (getBinderInfoArity info1) (getBinderInfoArity info2)) --- (orBinderInfo orig new) is used when combining occurrence --- info from branches of a case +-- (orBinderInfo orig new) is used +-- when combining occurrence info from branches of a case orBinderInfo DeadCode info2 = info2 orBinderInfo info1 DeadCode = info1 -orBinderInfo (OneOcc posn1 dup1 scc1 n_alts1 ar_1) - (OneOcc posn2 dup2 scc2 n_alts2 ar_2) +orBinderInfo (SingleOcc dup1 scc1 n_alts1 ar_1) + (SingleOcc dup2 scc2 n_alts2 ar_2) = let - -- Seriously maligned in order to make it stricter, - -- let's hope it is worth it.. - posn = combine_posns posn1 posn2 - scc = combine_sccs scc1 scc2 - dup = combine_dups dup1 dup2 + scc = or_sccs scc1 scc2 + dup = or_dups dup1 dup2 alts = n_alts1 + n_alts2 ar = min ar_1 ar_2 + in + SingleOcc dup scc alts ar - -- No CSE, please! - cont1 = case scc of { InsideSCC -> cont2; _ -> cont2 } - cont2 = case dup of { DupDanger -> cont3; _ -> cont3 } - cont3 = case alts of { (I# 0#) -> cont4; _ -> cont4 } - cont4 = case ar of { (I# 0#) -> cont5; _ -> cont5 } - cont5 = OneOcc posn dup scc alts ar - in - case posn of { FunOcc -> cont1; _ -> cont1 } orBinderInfo info1 info2 - = case (min (getBinderInfoArity info1) (getBinderInfoArity info2)) of - (I# i#) -> ManyOcc (I# i#) - --- (andBinderInfo orig new) is used in two situations: --- First, when a variable whose occurrence info --- is currently "orig" is bound to a variable whose occurrence info is "new" --- eg (\new -> e) orig --- What we want to do is to *worsen* orig's info to take account of new's --- --- second, when completing a let-binding --- let new = ...orig... --- we compute the way orig occurs in (...orig...), and then use orBinderInfo --- to worsen this info by the way new occurs in the let body; then we use --- that to worsen orig's currently recorded occurrence info. - -andBinderInfo DeadCode info2 = DeadCode -andBinderInfo info1 DeadCode = DeadCode -andBinderInfo (OneOcc posn1 dup1 scc1 (I# n_alts1#) (I# ar_1#)) - (OneOcc posn2 dup2 scc2 (I# n_alts2#) ar_2) - = let - -- Perversly maligned in order to make it stricter. - posn = combine_posns posn1 posn2 - scc = combine_sccs scc1 scc2 - dup = combine_dups dup1 dup2 - alts = I# (n_alts1# +# n_alts2#) + = ManyOcc (min (getBinderInfoArity info1) (getBinderInfoArity info2)) - -- No CSE, please! - cont1 = case scc of { InsideSCC -> cont2; _ -> cont2 } - cont2 = case dup of { DupDanger -> cont3; _ -> cont3 } - cont3 = case alts of { (I# 0#) -> cont4; _ -> cont4 } - cont4 = OneOcc posn dup scc alts (I# ar_1#) - in - case posn of {FunOcc -> cont1; _ -> cont1} +or_dups in_lam1 in_lam2 = in_lam1 || in_lam2 -andBinderInfo info1 info2 = - case getBinderInfoArity info1 of - (I# i#) -> ManyOcc (I# i#) - --ManyOcc (getBinderInfoArity info1) - - -combine_posns FunOcc FunOcc = FunOcc -- see comment at FunOrArg defn -combine_posns _ _ = ArgOcc - -combine_dups DupDanger _ = DupDanger -- Too paranoid?? ToDo -combine_dups _ DupDanger = DupDanger -combine_dups _ _ = NoDupDanger - -combine_sccs InsideSCC _ = InsideSCC -- Too paranoid?? ToDo -combine_sccs _ InsideSCC = InsideSCC -combine_sccs _ _ = NotInsideSCC +or_sccs InsideSCC _ = InsideSCC +or_sccs _ InsideSCC = InsideSCC +or_sccs _ _ = NotInsideSCC setBinderInfoArityToZero :: BinderInfo -> BinderInfo setBinderInfoArityToZero DeadCode = DeadCode setBinderInfoArityToZero (ManyOcc _) = ManyOcc 0 -setBinderInfoArityToZero (OneOcc fa dd sc i _) = OneOcc fa dd sc i 0 +setBinderInfoArityToZero (SingleOcc dd sc i _) = SingleOcc dd sc i 0 \end{code} \begin{code} getBinderInfoArity (DeadCode) = 0 getBinderInfoArity (ManyOcc i) = i -getBinderInfoArity (OneOcc _ _ _ _ i) = i +getBinderInfoArity (SingleOcc _ _ _ i) = i \end{code} \begin{code} instance Outputable BinderInfo where - ppr sty DeadCode = ptext SLIT("Dead") - ppr sty (ManyOcc ar) = hcat [ ptext SLIT("Many-"), int ar ] - ppr sty (OneOcc posn dup_danger in_scc n_alts ar) - = hcat [ ptext SLIT("One-"), pp_posn posn, char '-', pp_danger dup_danger, + ppr DeadCode = ptext SLIT("Dead") + ppr (ManyOcc ar) = hcat [ ptext SLIT("Many-"), int ar ] + ppr (SingleOcc dup_danger in_scc n_alts ar) + = hcat [ ptext SLIT("One-"), ppr dup_danger, char '-', pp_scc in_scc, char '-', int n_alts, char '-', int ar ] where - pp_posn FunOcc = ptext SLIT("fun") - pp_posn ArgOcc = ptext SLIT("arg") - - pp_danger DupDanger = ptext SLIT("*dup*") - pp_danger NoDupDanger = ptext SLIT("nodup") - pp_scc InsideSCC = ptext SLIT("*SCC*") pp_scc NotInsideSCC = ptext SLIT("noscc") \end{code} -