Commit 6d493299 authored by simonpj's avatar simonpj

[project @ 2003-09-23 15:29:02 by simonpj]

--------------------------
         Much grunting about let-floating
	   --------------------------

We want to avoid putting bindings between the '=' of a defn and a '\':
	let { f = let ... in \y-> ... } in ...

Reason: float-in often follows float-out, and it may then add yte
more bindings there, some of which may be strict.  But f may by
not be marked as not-demanded (for other reasons: see the call to
zapDemandInfo in Simplify.completeLazyBind); and now the strict binding
may not be able to float out again.  (Well, it triggers the ASSERT in
simplLazyBind.)

So this commit adds FloatOut.floatNonRecRhs (to complement floatRhs) which
is a big more vigorous about floating out.

But that in turn showed up a pile of gore to do with unlifted bindings.
We can't have them showing up at top level.  After thrashing in the swamp
for a while, I eventually arranged that
	let x# = e in b
(where x# has an unlifted type) is treated exactly like
	case e of x# -> b
That is, it is never floated.  Yes, we lose opportunities to float some
(very cheap!  unlifted let-bindings are always cheap) out of a lambda,
but we're missing much bigger opportunities already.  For example:
	\x -> f (h y)

where h :: Int -> Int# is expensive. We'd like to float the (h y) outside
the \x, but we don't because it's unboxed.  Possible solution: box it.
Anyway, that's for the future.
parent 6c4a98d3
...@@ -11,12 +11,13 @@ module FloatOut ( floatOutwards ) where ...@@ -11,12 +11,13 @@ module FloatOut ( floatOutwards ) where
#include "HsVersions.h" #include "HsVersions.h"
import CoreSyn import CoreSyn
import CoreUtils ( mkSCC ) import CoreUtils ( mkSCC, exprIsValue, exprIsTrivial )
import CmdLineOpts ( DynFlags, DynFlag(..), FloatOutSwitches(..) ) import CmdLineOpts ( DynFlags, DynFlag(..), FloatOutSwitches(..) )
import ErrUtils ( dumpIfSet_dyn ) import ErrUtils ( dumpIfSet_dyn )
import CostCentre ( dupifyCC, CostCentre ) import CostCentre ( dupifyCC, CostCentre )
import Id ( Id ) import Id ( Id, idType )
import Type ( isUnLiftedType )
import CoreLint ( showPass, endPass ) import CoreLint ( showPass, endPass )
import SetLevels ( Level(..), LevelledExpr, LevelledBind, import SetLevels ( Level(..), LevelledExpr, LevelledBind,
setLevels, ltMajLvl, ltLvl, isTopLvl ) setLevels, ltMajLvl, ltLvl, isTopLvl )
...@@ -99,8 +100,8 @@ vwhich might usefully be separated to ...@@ -99,8 +100,8 @@ vwhich might usefully be separated to
Well, maybe. We don't do this at the moment. Well, maybe. We don't do this at the moment.
\begin{code} \begin{code}
type FloatBind = (Level, CoreBind) type FloatBind = (Level, CoreBind) -- INVARIANT: a FloatBind is always lifted
type FloatBinds = [FloatBind] type FloatBinds = [FloatBind]
\end{code} \end{code}
%************************************************************************ %************************************************************************
...@@ -166,37 +167,36 @@ floatBind :: LevelledBind ...@@ -166,37 +167,36 @@ floatBind :: LevelledBind
-> (FloatStats, FloatBinds, CoreBind) -> (FloatStats, FloatBinds, CoreBind)
floatBind (NonRec (TB name level) rhs) floatBind (NonRec (TB name level) rhs)
= case (floatRhs level rhs) of { (fs, rhs_floats, rhs') -> = case (floatNonRecRhs level rhs) of { (fs, rhs_floats, rhs') ->
(fs, rhs_floats, NonRec name rhs') } (fs, rhs_floats, NonRec name rhs') }
floatBind bind@(Rec pairs) floatBind bind@(Rec pairs)
= case (unzip3 (map do_pair pairs)) of { (fss, rhss_floats, new_pairs) -> = case (unzip3 (map do_pair pairs)) of { (fss, rhss_floats, new_pairs) ->
if not (isTopLvl bind_level) then if not (isTopLvl bind_dest_level) then
-- Standard case -- Standard case; the floated bindings can't mention the
-- binders, because they couldn't be escaping a major level
-- if so.
(sum_stats fss, concat rhss_floats, Rec new_pairs) (sum_stats fss, concat rhss_floats, Rec new_pairs)
else else
-- In a recursive binding, *destined for* the top level -- In a recursive binding, *destined for* the top level
-- (only), the rhs floats may contain references to the -- (only), the rhs floats may contain references to the
-- bound things. For example -- bound things. For example
--
-- f = ...(let v = ...f... in b) ... -- f = ...(let v = ...f... in b) ...
--
-- might get floated to -- might get floated to
--
-- v = ...f... -- v = ...f...
-- f = ... b ... -- f = ... b ...
--
-- and hence we must (pessimistically) make all the floats recursive -- and hence we must (pessimistically) make all the floats recursive
-- with the top binding. Later dependency analysis will unravel it. -- with the top binding. Later dependency analysis will unravel it.
-- --
-- Can't happen on nested bindings because floatRhs will dump -- This can only happen for bindings destined for the top level,
-- the bindings in the RHS (partitionByMajorLevel treats top specially) -- because only then will partitionByMajorLevel allow through a binding
-- that only differs in its minor level
(sum_stats fss, [], (sum_stats fss, [],
Rec (new_pairs ++ floatsToBindPairs (concat rhss_floats))) Rec (new_pairs ++ floatsToBindPairs (concat rhss_floats)))
} }
where where
bind_level = getBindLevel bind bind_dest_level = getBindLevel bind
do_pair (TB name level, rhs) do_pair (TB name level, rhs)
= case (floatRhs level rhs) of { (fs, rhs_floats, rhs') -> = case (floatRhs level rhs) of { (fs, rhs_floats, rhs') ->
...@@ -211,22 +211,42 @@ floatBind bind@(Rec pairs) ...@@ -211,22 +211,42 @@ floatBind bind@(Rec pairs)
%************************************************************************ %************************************************************************
\begin{code} \begin{code}
floatExpr, floatRhs floatExpr, floatRhs, floatNonRecRhs
:: Level :: Level
-> LevelledExpr -> LevelledExpr
-> (FloatStats, FloatBinds, CoreExpr) -> (FloatStats, FloatBinds, CoreExpr)
floatRhs lvl arg floatRhs lvl arg -- Used rec rhss, and case-alternative rhss
= case (floatExpr lvl arg) of { (fsa, floats, arg') -> = case (floatExpr lvl arg) of { (fsa, floats, arg') ->
case (partitionByMajorLevel lvl floats) of { (floats', heres) -> case (partitionByMajorLevel lvl floats) of { (floats', heres) ->
-- Dump bindings that aren't going to escape from a lambda;
-- in particular, we must dump the ones that are bound by
-- the rec or case alternative
(fsa, floats', install heres arg') }}
floatNonRecRhs lvl arg -- Used for nested non-rec rhss, and fn args
= case (floatExpr lvl arg) of { (fsa, floats, arg') ->
-- Dump bindings that aren't going to escape from a lambda -- Dump bindings that aren't going to escape from a lambda
-- This is to avoid floating the x binding out of -- 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) -- f (let x = e in b)
-- unnecessarily. It even causes a bug to do so if we have -- unnecessarily. But we first test for values or trival rhss,
-- y = writeArr# a n (let x = e in b) -- because (in particular) we don't want to insert new bindings between
-- because the y binding is an expr-ok-for-speculation one. -- the "=" and the "\". E.g.
-- [SLPJ Dec 01: I don't understand this last comment; -- f = \x -> let <bind> in <body>
-- writeArr# is not ok-for-spec because of its side effect] -- 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.
if exprIsValue arg' || exprIsTrivial arg' then
(fsa, floats, arg')
else
case (partitionByMajorLevel lvl floats) of { (floats', heres) ->
(fsa, floats', install heres arg') }} (fsa, floats', install heres arg') }}
floatExpr _ (Var v) = (zeroStats, [], Var v) floatExpr _ (Var v) = (zeroStats, [], Var v)
...@@ -234,8 +254,8 @@ floatExpr _ (Type ty) = (zeroStats, [], Type ty) ...@@ -234,8 +254,8 @@ floatExpr _ (Type ty) = (zeroStats, [], Type ty)
floatExpr _ (Lit lit) = (zeroStats, [], Lit lit) floatExpr _ (Lit lit) = (zeroStats, [], Lit lit)
floatExpr lvl (App e a) floatExpr lvl (App e a)
= case (floatExpr lvl e) of { (fse, floats_e, e') -> = case (floatExpr lvl e) of { (fse, floats_e, e') ->
case (floatRhs lvl a) of { (fsa, floats_a, a') -> case (floatNonRecRhs lvl a) of { (fsa, floats_a, a') ->
(fse `add_stats` fsa, floats_e ++ floats_a, App e' a') }} (fse `add_stats` fsa, floats_e ++ floats_a, App e' a') }}
floatExpr lvl lam@(Lam _ _) floatExpr lvl lam@(Lam _ _)
...@@ -295,17 +315,18 @@ floatExpr lvl (Note note expr) -- Other than SCCs ...@@ -295,17 +315,18 @@ floatExpr lvl (Note note expr) -- Other than SCCs
= case (floatExpr lvl expr) of { (fs, floating_defns, expr') -> = case (floatExpr lvl expr) of { (fs, floating_defns, expr') ->
(fs, floating_defns, Note note expr') } (fs, floating_defns, Note note expr') }
floatExpr lvl (Let (NonRec (TB bndr bndr_lvl) rhs) body)
| isUnLiftedType (idType bndr) -- Treat unlifted lets just like a case
= case floatExpr lvl rhs of { (fs, rhs_floats, rhs') ->
case floatRhs bndr_lvl body of { (fs, body_floats, body') ->
(fs, rhs_floats ++ body_floats, Let (NonRec bndr rhs') body') }}
floatExpr lvl (Let bind body) floatExpr lvl (Let bind body)
= case (floatBind bind) of { (fsb, rhs_floats, bind') -> = case (floatBind bind) of { (fsb, rhs_floats, bind') ->
case (floatExpr lvl body) of { (fse, body_floats, body') -> case (floatExpr lvl body) of { (fse, body_floats, body') ->
-- if isInlineCtxt lvl then -- No floating inside an InlineMe (add_stats fsb fse,
-- ASSERT( null rhs_floats && null body_floats ) rhs_floats ++ [(bind_lvl, bind')] ++ body_floats,
-- (add_stats fsb fse, [], Let bind' body') body') }}
-- else
(add_stats fsb fse,
rhs_floats ++ [(bind_lvl, bind')] ++ body_floats,
body')
}}
where where
bind_lvl = getBindLevel bind bind_lvl = getBindLevel bind
......
...@@ -309,6 +309,23 @@ lvlExpr ctxt_lvl env expr@(_, AnnLam bndr rhs) ...@@ -309,6 +309,23 @@ lvlExpr ctxt_lvl env expr@(_, AnnLam bndr rhs)
-- but not nearly so much now non-recursive newtypes are transparent. -- but not nearly so much now non-recursive newtypes are transparent.
-- [See SetLevels rev 1.50 for a version with this approach.] -- [See SetLevels rev 1.50 for a version with this approach.]
lvlExpr ctxt_lvl env (_, AnnLet (AnnNonRec bndr rhs) body)
| isUnLiftedType (idType bndr)
-- Treat unlifted let-bindings (let x = b in e) just like (case b of x -> e)
-- That is, leave it exactly where it is
-- We used to float unlifted bindings too (e.g. to get a cheap primop
-- outside a lambda (to see how, look at lvlBind in rev 1.58)
-- but an unrelated change meant that these unlifed bindings
-- could get to the top level which is bad. And there's not much point;
-- unlifted bindings are always cheap, and so hardly worth floating.
= lvlExpr ctxt_lvl env rhs `thenLvl` \ rhs' ->
lvlExpr incd_lvl env' body `thenLvl` \ body' ->
returnLvl (Let (NonRec bndr' rhs') body')
where
incd_lvl = incMinorLvl ctxt_lvl
bndr' = TB bndr incd_lvl
env' = extendLvlEnv env [bndr']
lvlExpr ctxt_lvl env (_, AnnLet bind body) lvlExpr ctxt_lvl env (_, AnnLet bind body)
= lvlBind NotTopLevel ctxt_lvl env bind `thenLvl` \ (bind', new_env) -> = lvlBind NotTopLevel ctxt_lvl env bind `thenLvl` \ (bind', new_env) ->
lvlExpr ctxt_lvl new_env body `thenLvl` \ body' -> lvlExpr ctxt_lvl new_env body `thenLvl` \ body' ->
...@@ -335,6 +352,13 @@ lvlExpr ctxt_lvl env (_, AnnCase expr case_bndr alts) ...@@ -335,6 +352,13 @@ lvlExpr ctxt_lvl env (_, AnnCase expr case_bndr alts)
@lvlMFE@ is just like @lvlExpr@, except that it might let-bind @lvlMFE@ is just like @lvlExpr@, except that it might let-bind
the expression, so that it can itself be floated. the expression, so that it can itself be floated.
[NOTE: unlifted MFEs]
We don't float unlifted MFEs, which potentially loses big opportunites.
For example:
\x -> f (h y)
where h :: Int -> Int# is expensive. We'd like to float the (h y) outside
the \x, but we don't because it's unboxed. Possible solution: box it.
\begin{code} \begin{code}
lvlMFE :: Bool -- True <=> strict context [body of case or let] lvlMFE :: Bool -- True <=> strict context [body of case or let]
-> Level -- Level of innermost enclosing lambda/tylam -> Level -- Level of innermost enclosing lambda/tylam
...@@ -345,8 +369,9 @@ lvlMFE :: Bool -- True <=> strict context [body of case or let] ...@@ -345,8 +369,9 @@ lvlMFE :: Bool -- True <=> strict context [body of case or let]
lvlMFE strict_ctxt ctxt_lvl env (_, AnnType ty) lvlMFE strict_ctxt ctxt_lvl env (_, AnnType ty)
= returnLvl (Type ty) = returnLvl (Type ty)
lvlMFE strict_ctxt ctxt_lvl env ann_expr@(fvs, _) lvlMFE strict_ctxt ctxt_lvl env ann_expr@(fvs, _)
| isUnLiftedType ty -- Can't let-bind it | isUnLiftedType ty -- Can't let-bind it; see [NOTE: unlifted MFEs]
|| isInlineCtxt ctxt_lvl -- Don't float out of an __inline__ context || isInlineCtxt ctxt_lvl -- Don't float out of an __inline__ context
|| exprIsTrivial expr -- Never float if it's trivial || exprIsTrivial expr -- Never float if it's trivial
|| not good_destination || not good_destination
...@@ -420,7 +445,7 @@ lvlBind :: TopLevelFlag -- Used solely to decide whether to clone ...@@ -420,7 +445,7 @@ lvlBind :: TopLevelFlag -- Used solely to decide whether to clone
-> LvlM (LevelledBind, LevelEnv) -> LvlM (LevelledBind, LevelEnv)
lvlBind top_lvl ctxt_lvl env (AnnNonRec bndr rhs@(rhs_fvs,_)) lvlBind top_lvl ctxt_lvl env (AnnNonRec bndr rhs@(rhs_fvs,_))
| isInlineCtxt ctxt_lvl -- Don't do anything inside InlineMe | isInlineCtxt ctxt_lvl -- Don't do anything inside InlineMe
= lvlExpr ctxt_lvl env rhs `thenLvl` \ rhs' -> = lvlExpr ctxt_lvl env rhs `thenLvl` \ rhs' ->
returnLvl (NonRec (TB bndr ctxt_lvl) rhs', env) returnLvl (NonRec (TB bndr ctxt_lvl) rhs', env)
...@@ -439,12 +464,7 @@ lvlBind top_lvl ctxt_lvl env (AnnNonRec bndr rhs@(rhs_fvs,_)) ...@@ -439,12 +464,7 @@ lvlBind top_lvl ctxt_lvl env (AnnNonRec bndr rhs@(rhs_fvs,_))
where where
bind_fvs = rhs_fvs `unionVarSet` idFreeVars bndr bind_fvs = rhs_fvs `unionVarSet` idFreeVars bndr
abs_vars = abstractVars dest_lvl env bind_fvs abs_vars = abstractVars dest_lvl env bind_fvs
dest_lvl = destLevel env bind_fvs (isFunction rhs)
dest_lvl | isUnLiftedType (idType bndr) = destLevel env bind_fvs False `maxLvl` Level 1 0
| otherwise = destLevel env bind_fvs (isFunction rhs)
-- Hack alert! We do have some unlifted bindings, for cheap primops, and
-- it is ok to float them out; but not to the top level. If they would otherwise
-- go to the top level, we pin them inside the topmost lambda
\end{code} \end{code}
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment