import Id ( Id, idType, idArity, isBottomingId )
import Type ( isUnLiftedType )
import SetLevels ( Level(..), LevelledExpr, LevelledBind,
- setLevels, isTopLvl, tOP_LEVEL )
+ setLevels, isTopLvl )
import UniqSupply ( UniqSupply )
import Bag
import Util
import Maybes
-import UniqFM
import Outputable
import FastString
+import qualified Data.IntMap as M
+
+#include "HsVersions.h"
\end{code}
-----------------
floatTopBind :: LevelledBind -> (FloatStats, [CoreBind])
floatTopBind bind
= case (floatBind bind) of { (fs, floats) ->
- (fs, bagToList (flattenFloats floats))
- }
+ (fs, bagToList (flattenFloats floats)) }
\end{code}
%************************************************************************
\begin{code}
floatBind :: LevelledBind -> (FloatStats, FloatBinds)
-
floatBind (NonRec (TB var level) rhs)
= case (floatRhs level rhs) of { (fs, rhs_floats, rhs') ->
in (fs, rhs_floats `plusFloats` unitFloat level (NonRec var rhs'')) }
-floatBind bind@(Rec pairs)
- = case (unzip3 (map do_pair pairs)) of { (fss, rhss_floats, new_pairs) ->
- let rhs_floats = foldr1 plusFloats rhss_floats in
-
- if not (isTopLvl bind_dest_lvl) then
+floatBind (Rec pairs)
+ = case floatList do_pair pairs of { (fs, rhs_floats, new_pairs) ->
+ -- NB: the rhs floats may contain references to the
+ -- bound things. For example
+ -- f = ...(let v = ...f... in b) ...
+ if not (isTopLvl dest_lvl) then
-- Find which bindings float out at least one lambda beyond this one
-- These ones can't mention the binders, because they couldn't
-- be escaping a major level if so.
-- The ones that are not going further can join the letrec;
-- they may not be mutually recursive but the occurrence analyser will
- -- find that out.
- case (partitionByMajorLevel bind_dest_lvl rhs_floats) of { (floats', heres) ->
- (sum_stats fss,
- floats' `plusFloats` unitFloat bind_dest_lvl
- (Rec (floatsToBindPairs heres new_pairs))) }
- else
- -- In a recursive binding, *destined for* the top level
- -- (only), the rhs floats may contain references to the
- -- bound things. For example
- -- f = ...(let v = ...f... in b) ...
- -- might get floated to
+ -- find that out. In our example we make a Rec thus:
-- v = ...f...
-- f = ... b ...
- -- and hence we must (pessimistically) make all the floats recursive
- -- with the top binding. Later dependency analysis will unravel it.
- --
- -- This can only happen for bindings destined for the top level,
- -- because only then will partitionByMajorLevel allow through a binding
- -- that only differs in its minor level
- (sum_stats fss, unitFloat tOP_LEVEL
- (Rec (floatsToBindPairs (flattenFloats rhs_floats) new_pairs)))
- }
+ case (partitionByMajorLevel dest_lvl rhs_floats) of { (floats', heres) ->
+ (fs, floats' `plusFloats` unitFloat dest_lvl
+ (Rec (floatsToBindPairs heres new_pairs))) }
+ else
+ -- For top level, no need to partition; just make them all recursive
+ -- (And the partition wouldn't work because they'd all end up in floats')
+ (fs, unitFloat dest_lvl
+ (Rec (floatsToBindPairs (flattenFloats rhs_floats) new_pairs))) }
where
- bind_dest_lvl = getBindLevel bind
+ (((TB _ dest_lvl), _) : _) = pairs
do_pair (TB name level, rhs)
= case (floatRhs level rhs) of { (fs, rhs_floats, rhs') ->
- (fs, rhs_floats, (name, rhs'))
- }
+ (fs, rhs_floats, (name, rhs')) }
+
+---------------
+floatList :: (a -> (FloatStats, FloatBinds, b)) -> [a] -> (FloatStats, FloatBinds, [b])
+floatList _ [] = (zeroStats, emptyFloats, [])
+floatList f (a:as) = case f a of { (fs_a, binds_a, b) ->
+ case floatList f as of { (fs_as, binds_as, bs) ->
+ (fs_a `add_stats` fs_as, binds_a `plusFloats` binds_as, b:bs) }}
\end{code}
+
%************************************************************************
\subsection[FloatOut-Expr]{Floating in expressions}
-- the rec or case alternative
(fsa, floats', install heres arg') }}
+-----------------
floatRhs lvl arg -- Used for nested non-rec rhss, and fn args
-- See Note [Floating out of RHS]
- = case (floatExpr lvl arg) of { (fsa, floats, arg') ->
- if exprIsCheap arg' then
- (fsa, floats, arg')
- else
- case (partitionByMajorLevel lvl floats) of { (floats', heres) ->
- (fsa, floats', install heres arg') }}
-
--- Note [Floating out of RHSs]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~
--- Dump bindings that aren't going to escape from a lambda
--- This isn't a scoping issue (the binder isn't in scope in the RHS
--- of a non-rec binding)
--- Rather, it is to avoid floating the x binding out of
--- f (let x = e in b)
--- unnecessarily. But we first test for values or trival rhss,
--- because (in particular) we don't want to insert new bindings between
--- the "=" and the "\". E.g.
--- f = \x -> let <bind> in <body>
--- We do not want
--- f = let <bind> in \x -> <body>
--- (a) The simplifier will immediately float it further out, so we may
--- as well do so right now; in general, keeping rhss as manifest
--- values is good
--- (b) If a float-in pass follows immediately, it might add yet more
--- bindings just after the '='. And some of them might (correctly)
--- be strict even though the 'let f' is lazy, because f, being a value,
--- gets its demand-info zapped by the simplifier.
---
--- We use exprIsCheap because that is also what's used by the simplifier
--- to decide whether to float a let out of a let
+ = floatExpr lvl arg
+-----------------
floatExpr _ (Var v) = (zeroStats, emptyFloats, Var v)
floatExpr _ (Type ty) = (zeroStats, emptyFloats, Type ty)
+floatExpr _ (Coercion co) = (zeroStats, emptyFloats, Coercion co)
floatExpr _ (Lit lit) = (zeroStats, emptyFloats, Lit lit)
floatExpr lvl (App e a)
case (floatRhs lvl a) of { (fsa, floats_a, a') ->
(fse `add_stats` fsa, floats_e `plusFloats` floats_a, App e' a') }}
-floatExpr _ lam@(Lam _ _)
- = let
- (bndrs_w_lvls, body) = collectBinders lam
+floatExpr _ lam@(Lam (TB _ lam_lvl) _)
+ = let (bndrs_w_lvls, body) = collectBinders lam
bndrs = [b | TB b _ <- bndrs_w_lvls]
- lvls = [l | TB _ l <- bndrs_w_lvls]
-
- -- For the all-tyvar case we are prepared to pull
- -- the lets out, to implement the float-out-of-big-lambda
- -- transform; but otherwise we only float bindings that are
- -- going to escape a value lambda.
- -- In particular, for one-shot lambdas we don't float things
- -- out; we get no saving by so doing.
- partition_fn | all isTyVar bndrs = partitionByLevel
- | otherwise = partitionByMajorLevel
+ -- All the binders have the same level
+ -- See SetLevels.lvlLamBndrs
in
- case (floatExpr (last lvls) body) of { (fs, floats, body') ->
-
- -- Dump any bindings which absolutely cannot go any further
- case (partition_fn (head lvls) floats) of { (floats', heres) ->
-
- (add_to_stats fs floats', floats', mkLams bndrs (install heres body'))
+ case (floatExpr lam_lvl body) of { (fs, floats, body1) ->
+
+ -- Dump anything that is captured by this lambda
+ -- Eg \x -> ...(\y -> let v = <blah> in ...)...
+ -- We'll have the binding (v = <blah>) in the floats,
+ -- but must dump it at the lambda-x
+ case (partitionByLevel lam_lvl floats) of { (floats1, heres) ->
+ (add_to_stats fs floats1, floats1, mkLams bndrs (install heres body1))
}}
floatExpr lvl (Note note@(SCC cc) expr)
floatExpr lvl (Let bind body)
= case (floatBind bind) of { (fsb, bind_floats) ->
case (floatExpr lvl body) of { (fse, body_floats, body') ->
- (add_stats fsb fse,
- bind_floats `plusFloats` body_floats,
- body') }}
+ case partitionByMajorLevel lvl (bind_floats `plusFloats` body_floats)
+ of { (floats, heres) ->
+ -- See Note [Avoiding unnecessary floating]
+ (add_stats fsb fse, floats, install heres body') } } }
floatExpr lvl (Case scrut (TB case_bndr case_lvl) ty alts)
= case floatExpr lvl scrut of { (fse, fde, scrut') ->
float_alt (con, bs, rhs)
= case (floatCaseAlt case_lvl rhs) of { (fs, rhs_floats, rhs') ->
(fs, rhs_floats, (con, [b | TB b _ <- bs], rhs')) }
-
-
-floatList :: (a -> (FloatStats, FloatBinds, b)) -> [a] -> (FloatStats, FloatBinds, [b])
-floatList _ [] = (zeroStats, emptyFloats, [])
-floatList f (a:as) = case f a of { (fs_a, binds_a, b) ->
- case floatList f as of { (fs_as, binds_as, bs) ->
- (fs_a `add_stats` fs_as, binds_a `plusFloats` binds_as, b:bs) }}
-
-getBindLevel :: Bind (TaggedBndr Level) -> Level
-getBindLevel (NonRec (TB _ lvl) _) = lvl
-getBindLevel (Rec (((TB _ lvl), _) : _)) = lvl
-getBindLevel (Rec []) = panic "getBindLevel Rec []"
\end{code}
+Note [Avoiding unnecessary floating]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In general we want to avoid floating a let unnecessarily, because
+it might worsen strictness:
+ let
+ x = ...(let y = e in y+y)....
+Here y is demanded. If we float it outside the lazy 'x=..' then
+we'd have to zap its demand info, and it may never be restored.
+
+So at a 'let' we leave the binding right where the are unless
+the binding will escape a value lambda. That's what the
+partitionByMajorLevel does in the floatExpr (Let ...) case.
+
+Notice, though, that we must take care to drop any bindings
+from the body of the let that depend on the staying-put bindings.
+
+We used instead to do the partitionByMajorLevel on the RHS of an '=',
+in floatRhs. But that was quite tiresome. We needed to test for
+values or trival rhss, because (in particular) we don't want to insert
+new bindings between the "=" and the "\". E.g.
+ f = \x -> let <bind> in <body>
+We do not want
+ f = let <bind> in \x -> <body>
+(a) The simplifier will immediately float it further out, so we may
+ as well do so right now; in general, keeping rhss as manifest
+ values is good
+(b) If a float-in pass follows immediately, it might add yet more
+ bindings just after the '='. And some of them might (correctly)
+ be strict even though the 'let f' is lazy, because f, being a value,
+ gets its demand-info zapped by the simplifier.
+And even all that turned out to be very fragile, and broke
+altogether when profiling got in the way.
+
+So now we do the partition right at the (Let..) itself.
+
%************************************************************************
%* *
\subsection{Utility bits for floating stats}
!MajorEnv -- Levels other than top
-- See Note [Representation of FloatBinds]
-type MajorEnv = UniqFM MinorEnv -- Keyed by major level
-type MinorEnv = UniqFM (Bag FloatBind) -- Keyed by minor level
+instance Outputable FloatBinds where
+ ppr (FB fbs env) = ptext (sLit "FB") <+> (braces $ vcat
+ [ ptext (sLit "binds =") <+> ppr fbs
+ , ptext (sLit "env =") <+> ppr env ])
+
+type MajorEnv = M.IntMap MinorEnv -- Keyed by major level
+type MinorEnv = M.IntMap (Bag FloatBind) -- Keyed by minor level
flattenFloats :: FloatBinds -> Bag FloatBind
flattenFloats (FB tops others) = tops `unionBags` flattenMajor others
flattenMajor :: MajorEnv -> Bag FloatBind
-flattenMajor = foldUFM (unionBags . flattenMinor) emptyBag
+flattenMajor = M.fold (unionBags . flattenMinor) emptyBag
flattenMinor :: MinorEnv -> Bag FloatBind
-flattenMinor = foldUFM unionBags emptyBag
+flattenMinor = M.fold unionBags emptyBag
emptyFloats :: FloatBinds
-emptyFloats = FB emptyBag emptyUFM
+emptyFloats = FB emptyBag M.empty
unitFloat :: Level -> FloatBind -> FloatBinds
unitFloat lvl@(Level major minor) b
- | isTopLvl lvl = FB (unitBag b) emptyUFM
- | otherwise = FB emptyBag (unitUFM major (unitUFM minor (unitBag b)))
+ | isTopLvl lvl = FB (unitBag b) M.empty
+ | otherwise = FB emptyBag (M.singleton major (M.singleton minor (unitBag b)))
plusFloats :: FloatBinds -> FloatBinds -> FloatBinds
plusFloats (FB t1 b1) (FB t2 b2) = FB (t1 `unionBags` t2) (b1 `plusMajor` b2)
plusMajor :: MajorEnv -> MajorEnv -> MajorEnv
-plusMajor = plusUFM_C plusMinor
+plusMajor = M.unionWith plusMinor
plusMinor :: MinorEnv -> MinorEnv -> MinorEnv
-plusMinor = plusUFM_C unionBags
+plusMinor = M.unionWith unionBags
floatsToBindPairs :: Bag FloatBind -> [(Id,CoreExpr)] -> [(Id,CoreExpr)]
floatsToBindPairs floats binds = foldrBag add binds floats
partitionByMajorLevel (Level major _) (FB tops defns)
= (FB tops outer, heres `unionBags` flattenMajor inner)
where
- (outer, mb_heres, inner) = splitUFM defns major
+ (outer, mb_heres, inner) = M.splitLookup major defns
heres = case mb_heres of
Nothing -> emptyBag
Just h -> flattenMinor h
partitionByLevel (Level major minor) (FB tops defns)
- = (FB tops (outer_maj `plusMajor` unitUFM major outer_min),
+ = (FB tops (outer_maj `plusMajor` M.singleton major outer_min),
here_min `unionBags` flattenMinor inner_min
`unionBags` flattenMajor inner_maj)
where
- (outer_maj, mb_here_maj, inner_maj) = splitUFM defns major
+ (outer_maj, mb_here_maj, inner_maj) = M.splitLookup major defns
(outer_min, mb_here_min, inner_min) = case mb_here_maj of
- Nothing -> (emptyUFM, Nothing, emptyUFM)
- Just min_defns -> splitUFM min_defns minor
+ Nothing -> (M.empty, Nothing, M.empty)
+ Just min_defns -> M.splitLookup minor min_defns
here_min = mb_here_min `orElse` emptyBag
wrapCostCentre :: CostCentre -> FloatBinds -> FloatBinds
wrapCostCentre cc (FB tops defns)
- = FB (wrap_defns tops) (mapUFM (mapUFM wrap_defns) defns)
+ = FB (wrap_defns tops) (M.map (M.map wrap_defns) defns)
where
wrap_defns = mapBag wrap_one
wrap_one (NonRec binder rhs) = NonRec binder (mkSCC cc rhs)
wrap_one (Rec pairs) = Rec (mapSnd (mkSCC cc) pairs)
\end{code}
-
projects / ghc-hetmet.git / blobdiff