%************************************************************************
\begin{code}
-#include "HsVersions.h"
-
module BinderInfo (
BinderInfo(..),
FunOrArg, DuplicationDanger, InsideSCC, -- NB: all abstract (yay!)
addBinderInfo, orBinderInfo, andBinderInfo,
- argOccurrence, funOccurrence, dangerousArgOcc, noBinderInfo,
+ deadOccurrence, argOccurrence, funOccurrence, dangerousArgOcc, noBinderInfo,
+
markMany, markDangerousToDup, markInsideSCC,
getBinderInfoArity,
setBinderInfoArityToZero,
+ okToInline, isOneOcc, isOneFunOcc, isOneSafeFunOcc, isDeadOcc,
+
isFun, isDupDanger -- for Simon Marlow deforestation
) where
-IMP_Ubiq(){-uitous-}
+#include "HsVersions.h"
-import Pretty
import Util ( panic )
+import GlaExts ( Int(..), (+#) )
+import Outputable
+
\end{code}
The @BinderInfo@ describes how a variable is used in a given scope.
| 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
-- mutually-exclusive case alts).
- FunOrArg -- How it occurs
+ !FunOrArg -- How it occurs
- DuplicationDanger
+ !DuplicationDanger
- 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
-- 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)
\begin{code}
+isOneOcc :: BinderInfo -> Bool
+isOneOcc (OneOcc _ _ _ _ _) = True
+isOneOcc other_bind = False
+
+isOneFunOcc :: BinderInfo -> Bool
+isOneFunOcc (OneOcc FunOcc _ _ _ _) = True
+isOneFunOcc other_bind = False
+
+isOneSafeFunOcc :: Bool -> BinderInfo -> Bool
+isOneSafeFunOcc ok_to_dup (OneOcc FunOcc NoDupDanger NotInsideSCC n_alts _)
+ = ok_to_dup || n_alts <= 1
+isOneSafeFunOcc ok_to_dup other_bind = False
+
+isDeadOcc :: BinderInfo -> Bool
+isDeadOcc DeadCode = True
+isDeadOcc other = False
+
isFun :: FunOrArg -> Bool
isFun FunOcc = True
isFun _ = False
isDupDanger _ = False
\end{code}
-@inlineUnconditionally@ decides whether a let-bound thing can
-definitely be inlined.
\begin{code}
-{- NOT USED
-
-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
--}
+okToInline :: Bool -- The thing is WHNF or bottom;
+ -> Bool -- It's small enough to duplicate the code
+ -> BinderInfo
+ -> Bool -- True <=> inline it
+
+-- A non-WHNF can be inlined if it doesn't occur inside a lambda,
+-- and occurs exactly once or
+-- occurs once in each branch of a case and is small
+okToInline False small_enough (OneOcc _ NoDupDanger _ n_alts _)
+ = n_alts <= 1 || small_enough
+
+-- If the thing isn't a redex, there's no danger of duplicating work,
+-- so we can inline if it occurs once, or is small
+okToInline True small_enough occ_info
+ = one_occ || small_enough
+ where
+ one_occ = case occ_info of
+ OneOcc _ _ _ n_alts _ -> n_alts <= 1
+ other -> False
+
+okToInline whnf_or_bot small_enough any_occ = False
\end{code}
Construction
~~~~~~~~~~~~~
\begin{code}
+deadOccurrence :: BinderInfo
+deadOccurrence = DeadCode
+
argOccurrence, funOccurrence :: Int -> BinderInfo
funOccurrence = OneOcc FunOcc NoDupDanger NotInsideSCC 1
addBinderInfo DeadCode info2 = info2
addBinderInfo info1 DeadCode = info1
addBinderInfo info1 info2
- = 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 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 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)
- = OneOcc (combine_posns posn1 posn2)
- (combine_dups dup1 dup2)
- (combine_sccs scc1 scc2)
- (n_alts1 + n_alts2)
- (min ar_1 ar_2)
+ = let
+ posn = combine_posns posn1 posn2
+ scc = combine_sccs scc1 scc2
+ dup = combine_dups dup1 dup2
+ alts = n_alts1 + n_alts2
+ ar = min ar_1 ar_2
+ in
+ OneOcc posn dup scc alts ar
+
orBinderInfo info1 info2
- = ManyOcc (min (getBinderInfoArity info1) (getBinderInfoArity info2))
+ = ManyOcc (min (getBinderInfoArity info1) (getBinderInfoArity info2))
--- (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
+-- (andBinderInfo orig new) is used
+-- when completing a let-binding
-- let new = ...orig...
--- we compute the way orig occurs in (...orig...), and then use orBinderInfo
+-- we compute the way orig occurs in (...orig...), and then use andBinderInfo
-- 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 info1 DeadCode = DeadCode
andBinderInfo (OneOcc posn1 dup1 scc1 n_alts1 ar_1)
(OneOcc posn2 dup2 scc2 n_alts2 ar_2)
- = OneOcc (combine_posns posn1 posn2)
- (combine_dups dup1 dup2)
- (combine_sccs scc1 scc2)
- (n_alts1 + n_alts2)
- ar_1 -- Min arity just from orig
+ = let
+ posn = combine_posns posn1 posn2
+ scc = combine_sccs scc1 scc2
+ dup = combine_dups dup1 dup2
+ alts = n_alts1 + n_alts2
+ in
+ OneOcc posn dup scc alts ar_1
+
andBinderInfo info1 info2 = ManyOcc (getBinderInfoArity info1)
combine_dups DupDanger _ = DupDanger -- Too paranoid?? ToDo
combine_dups _ DupDanger = DupDanger
-combine_dups _ _ = NoDupDanger
+combine_dups _ _ = NoDupDanger
combine_sccs InsideSCC _ = InsideSCC -- Too paranoid?? ToDo
combine_sccs _ InsideSCC = InsideSCC
\begin{code}
instance Outputable BinderInfo where
- ppr sty DeadCode = ppStr "Dead"
- ppr sty (ManyOcc ar) = ppBesides [ ppStr "Many-", ppInt ar ]
- ppr sty (OneOcc posn dup_danger in_scc n_alts ar)
- = ppBesides [ ppStr "One-", pp_posn posn, ppChar '-', pp_danger dup_danger,
- ppChar '-', pp_scc in_scc, ppChar '-', ppInt n_alts,
- ppChar '-', ppInt ar ]
+ ppr DeadCode = ptext SLIT("Dead")
+ ppr (ManyOcc ar) = hcat [ ptext SLIT("Many-"), int ar ]
+ ppr (OneOcc posn dup_danger in_scc n_alts ar)
+ = hcat [ ptext SLIT("One-"), pp_posn posn, char '-', pp_danger dup_danger,
+ char '-', pp_scc in_scc, char '-', int n_alts,
+ char '-', int ar ]
where
- pp_posn FunOcc = ppStr "fun"
- pp_posn ArgOcc = ppStr "arg"
+ pp_posn FunOcc = ptext SLIT("fun")
+ pp_posn ArgOcc = ptext SLIT("arg")
- pp_danger DupDanger = ppStr "*dup*"
- pp_danger NoDupDanger = ppStr "nodup"
+ pp_danger DupDanger = ptext SLIT("*dup*")
+ pp_danger NoDupDanger = ptext SLIT("nodup")
- pp_scc InsideSCC = ppStr "*SCC*"
- pp_scc NotInsideSCC = ppStr "noscc"
+ pp_scc InsideSCC = ptext SLIT("*SCC*")
+ pp_scc NotInsideSCC = ptext SLIT("noscc")
\end{code}
projects / ghc-hetmet.git / blobdiff