Commit 6d493299 authored by simonpj's avatar simonpj
Browse files

[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

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
#include "HsVersions.h"
import CoreSyn
import CoreUtils ( mkSCC )
import CoreUtils ( mkSCC, exprIsValue, exprIsTrivial )
import CmdLineOpts ( DynFlags, DynFlag(..), FloatOutSwitches(..) )
import ErrUtils ( dumpIfSet_dyn )
import CostCentre ( dupifyCC, CostCentre )
import Id ( Id )
import Id ( Id, idType )
import Type ( isUnLiftedType )
import CoreLint ( showPass, endPass )
import SetLevels ( Level(..), LevelledExpr, LevelledBind,
setLevels, ltMajLvl, ltLvl, isTopLvl )
......@@ -99,7 +100,7 @@ vwhich might usefully be separated to
Well, maybe. We don't do this at the moment.
type FloatBind = (Level, CoreBind)
type FloatBind = (Level, CoreBind) -- INVARIANT: a FloatBind is always lifted
type FloatBinds = [FloatBind]
......@@ -166,37 +167,36 @@ floatBind :: LevelledBind
-> (FloatStats, FloatBinds, CoreBind)
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') }
floatBind bind@(Rec pairs)
= case (unzip3 (map do_pair pairs)) of { (fss, rhss_floats, new_pairs) ->
if not (isTopLvl bind_level) then
-- Standard case
if not (isTopLvl bind_dest_level) then
-- 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)
-- 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
-- v = ...f...
-- f = ... b ...
-- and hence we must (pessimistically) make all the floats recursive
-- with the top binding. Later dependency analysis will unravel it.
-- Can't happen on nested bindings because floatRhs will dump
-- the bindings in the RHS (partitionByMajorLevel treats top specially)
-- 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, [],
Rec (new_pairs ++ floatsToBindPairs (concat rhss_floats)))
bind_level = getBindLevel bind
bind_dest_level = getBindLevel bind
do_pair (TB name level, rhs)
= case (floatRhs level rhs) of { (fs, rhs_floats, rhs') ->
......@@ -211,22 +211,42 @@ floatBind bind@(Rec pairs)
floatExpr, floatRhs
floatExpr, floatRhs, floatNonRecRhs
:: Level
-> LevelledExpr
-> (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 (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
-- 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)
-- unnecessarily. It even causes a bug to do so if we have
-- y = writeArr# a n (let x = e in b)
-- because the y binding is an expr-ok-for-speculation one.
-- [SLPJ Dec 01: I don't understand this last comment;
-- writeArr# is not ok-for-spec because of its side effect]
-- 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.
if exprIsValue arg' || exprIsTrivial arg' then
(fsa, floats, arg')
case (partitionByMajorLevel lvl floats) of { (floats', heres) ->
(fsa, floats', install heres arg') }}
floatExpr _ (Var v) = (zeroStats, [], Var v)
......@@ -235,7 +255,7 @@ floatExpr _ (Lit lit) = (zeroStats, [], Lit lit)
floatExpr lvl (App e a)
= 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') }}
floatExpr lvl lam@(Lam _ _)
......@@ -295,17 +315,18 @@ floatExpr lvl (Note note expr) -- Other than SCCs
= case (floatExpr lvl expr) of { (fs, floating_defns, 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)
= case (floatBind bind) of { (fsb, rhs_floats, bind') ->
case (floatExpr lvl body) of { (fse, body_floats, body') ->
-- if isInlineCtxt lvl then -- No floating inside an InlineMe
-- ASSERT( null rhs_floats && null body_floats )
-- (add_stats fsb fse, [], Let bind' body')
-- else
(add_stats fsb fse,
rhs_floats ++ [(bind_lvl, bind')] ++ body_floats,
body') }}
bind_lvl = getBindLevel bind
......@@ -309,6 +309,23 @@ lvlExpr ctxt_lvl env expr@(_, AnnLam bndr rhs)
-- but not nearly so much now non-recursive newtypes are transparent.
-- [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')
incd_lvl = incMinorLvl ctxt_lvl
bndr' = TB bndr incd_lvl
env' = extendLvlEnv env [bndr']
lvlExpr ctxt_lvl env (_, AnnLet bind body)
= lvlBind NotTopLevel ctxt_lvl env bind `thenLvl` \ (bind', new_env) ->
lvlExpr ctxt_lvl new_env body `thenLvl` \ body' ->
......@@ -335,6 +352,13 @@ lvlExpr ctxt_lvl env (_, AnnCase expr case_bndr alts)
@lvlMFE@ is just like @lvlExpr@, except that it might let-bind
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.
lvlMFE :: Bool -- True <=> strict context [body of case or let]
-> Level -- Level of innermost enclosing lambda/tylam
......@@ -345,8 +369,9 @@ lvlMFE :: Bool -- True <=> strict context [body of case or let]
lvlMFE strict_ctxt ctxt_lvl env (_, AnnType ty)
= returnLvl (Type ty)
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
|| exprIsTrivial expr -- Never float if it's trivial
|| not good_destination
......@@ -439,12 +464,7 @@ lvlBind top_lvl ctxt_lvl env (AnnNonRec bndr rhs@(rhs_fvs,_))
bind_fvs = rhs_fvs `unionVarSet` idFreeVars bndr
abs_vars = abstractVars dest_lvl env bind_fvs
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
dest_lvl = destLevel env bind_fvs (isFunction rhs)
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