Commit e1231b2b authored by simonpj@microsoft.com's avatar simonpj@microsoft.com

Experimental flag -fdicts-cheap

This experimental flag, -fdicts-cheap, makes a let-binding that bind a
value of dictionary type look cheap.  That in turn leads to more
eta expansion.  Instead of
	f = /\a. \(d1:Ord a). let d2:Ord [a] = dfOrd a d1 in
                 \(x:a). <stuff>
which has arity 1, you get
	f = /\a. \(d1:Ord a). \(x:a).
	         let d2:Ord [a] = dfOrd a d1 in <stuff>
Now f has arity 2.

This can cretainly waste dictionary-construction work, if f is
partially applied to its dictionary argument.  However it has knock-on
effects.  Because f has arity 2, we won't float (f Int d) out of
	\x. h (f Int d)
Floating f out of this lambda makes it impossible for an h/f fusion
rule to fire; and this unexpected loss of RULE application was the
immediate reason for implementing this flag. (Roman Leshchinskiy came
across this when working on array fusion.)


I've implemented the change only in CoreUtils.arityType, which
only affects eta expansion.  I thought of putting the change in
exprIsCheap, which is a more systematic place (the former calls
the latter) but

	a) I wanted this under flag control, and the flags 
	are not readily available to all callers of exprIsCheap

	b) I'm not 100% convinced that this change is a good
	idea, so it's reasonable to do the narrowest change
	that solves the immediate problem.
parent 09c814ec
......@@ -58,7 +58,7 @@ import PrimOp ( PrimOp(..), primOpOkForSpeculation, primOpIsCheap )
import Id ( Id, idType, globalIdDetails, idNewStrictness,
mkWildId, idArity, idName, idUnfolding, idInfo,
isOneShotBndr, isStateHackType, isDataConWorkId_maybe, mkSysLocal,
isDataConWorkId, isBottomingId
isDataConWorkId, isBottomingId, isDictId
)
import IdInfo ( GlobalIdDetails(..), megaSeqIdInfo )
import NewDemand ( appIsBottom )
......@@ -74,6 +74,7 @@ import CostCentre ( CostCentre )
import BasicTypes ( Arity )
import Unique ( Unique )
import Outputable
import DynFlags ( DynFlags, DynFlag(Opt_DictsCheap), dopt )
import TysPrim ( alphaTy ) -- Debugging only
import Util ( equalLength, lengthAtLeast, foldl2 )
\end{code}
......@@ -432,8 +433,8 @@ exprIsCheap (Case e _ _ alts) = exprIsCheap e &&
exprIsCheap (Let (NonRec x _) e)
| isUnLiftedType (idType x) = exprIsCheap e
| otherwise = False
-- strict lets always have cheap right hand sides, and
-- do no allocation.
-- strict lets always have cheap right hand sides,
-- and do no allocation.
exprIsCheap other_expr
= go other_expr 0 True
......@@ -448,7 +449,7 @@ exprIsCheap other_expr
-- because it certainly doesn't need to be shared!
go (App f a) n_args args_cheap
| not (isRuntimeArg a) = go f n_args args_cheap
| not (isRuntimeArg a) = go f n_args args_cheap
| otherwise = go f (n_args + 1) (exprIsCheap a && args_cheap)
go other n_args args_cheap = False
......@@ -487,7 +488,6 @@ It returns True iff
soon,
without raising an exception,
without causing a side effect (e.g. writing a mutable variable)
E.G.
let x = case y# +# 1# of { r# -> I# r# }
in E
......@@ -706,7 +706,7 @@ exprIsConApp_maybe expr = analyse (collectArgs expr)
%************************************************************************
\begin{code}
exprEtaExpandArity :: CoreExpr -> Arity
exprEtaExpandArity :: DynFlags -> CoreExpr -> Arity
{- The Arity returned is the number of value args the
thing can be applied to without doing much work
......@@ -786,7 +786,7 @@ decopose Int to a function type. Hence the final case in eta_expand.
-}
exprEtaExpandArity e = arityDepth (arityType e)
exprEtaExpandArity dflags e = arityDepth (arityType dflags e)
-- A limited sort of function type
data ArityType = AFun Bool ArityType -- True <=> one-shot
......@@ -802,17 +802,17 @@ andArityType ATop at2 = ATop
andArityType (AFun t1 at1) (AFun t2 at2) = AFun (t1 && t2) (andArityType at1 at2)
andArityType at1 at2 = andArityType at2 at1
arityType :: CoreExpr -> ArityType
arityType :: DynFlags -> CoreExpr -> ArityType
-- (go1 e) = [b1,..,bn]
-- means expression can be rewritten \x_b1 -> ... \x_bn -> body
-- where bi is True <=> the lambda is one-shot
arityType (Note n e) = arityType e
arityType dflags (Note n e) = arityType dflags e
-- Not needed any more: etaExpand is cleverer
-- | ok_note n = arityType e
-- | ok_note n = arityType dflags e
-- | otherwise = ATop
arityType (Var v)
arityType dflags (Var v)
= mk (idArity v) (arg_tys (idType v))
where
mk :: Arity -> [Type] -> ArityType
......@@ -835,14 +835,15 @@ arityType (Var v)
| otherwise = []
-- Lambdas; increase arity
arityType (Lam x e) | isId x = AFun (isOneShotBndr x) (arityType e)
| otherwise = arityType e
arityType dflags (Lam x e)
| isId x = AFun (isOneShotBndr x) (arityType dflags e)
| otherwise = arityType dflags e
-- Applications; decrease arity
arityType (App f (Type _)) = arityType f
arityType (App f a) = case arityType f of
AFun one_shot xs | exprIsCheap a -> xs
other -> ATop
arityType dflags (App f (Type _)) = arityType dflags f
arityType dflags (App f a) = case arityType dflags f of
AFun one_shot xs | exprIsCheap a -> xs
other -> ATop
-- Case/Let; keep arity if either the expression is cheap
-- or it's a 1-shot lambda
......@@ -851,17 +852,40 @@ arityType (App f a) = case arityType f of
-- ===>
-- f x y = case x of { (a,b) -> e }
-- The difference is observable using 'seq'
arityType (Case scrut _ _ alts) = case foldr1 andArityType [arityType rhs | (_,_,rhs) <- alts] of
xs | exprIsCheap scrut -> xs
xs@(AFun one_shot _) | one_shot -> AFun True ATop
other -> ATop
arityType (Let b e) = case arityType e of
xs | all exprIsCheap (rhssOfBind b) -> xs
xs@(AFun one_shot _) | one_shot -> AFun True ATop
other -> ATop
arityType other = ATop
arityType dflags (Case scrut _ _ alts)
= case foldr1 andArityType [arityType dflags rhs | (_,_,rhs) <- alts] of
xs | exprIsCheap scrut -> xs
xs@(AFun one_shot _) | one_shot -> AFun True ATop
other -> ATop
arityType dflags (Let b e)
= case arityType dflags e of
xs | cheap_bind b -> xs
xs@(AFun one_shot _) | one_shot -> AFun True ATop
other -> ATop
where
cheap_bind (NonRec b e) = is_cheap (b,e)
cheap_bind (Rec prs) = all is_cheap prs
is_cheap (b,e) = (dopt Opt_DictsCheap dflags && isDictId b)
|| exprIsCheap e
-- If the experimental -fdicts-cheap flag is on, we eta-expand through
-- dictionary bindings. This improves arities. Thereby, it also
-- means that full laziness is less prone to floating out the
-- application of a function to its dictionary arguments, which
-- can thereby lose opportunities for fusion. Example:
-- foo :: Ord a => a -> ...
-- foo = /\a \(d:Ord a). let d' = ...d... in \(x:a). ....
-- -- So foo has arity 1
--
-- f = \x. foo dInt $ bar x
--
-- The (foo DInt) is floated out, and makes ineffective a RULE
-- foo (bar x) = ...
--
-- One could go further and make exprIsCheap reply True to any
-- dictionary-typed expression, but that's more work.
arityType dflags other = ATop
{- NOT NEEDED ANY MORE: etaExpand is cleverer
ok_note InlineMe = False
......
......@@ -168,6 +168,7 @@ data DynFlag
| Opt_DoEtaReduction
| Opt_CaseMerge
| Opt_UnboxStrictFields
| Opt_DictsCheap
-- misc opts
| Opt_Cpp
......@@ -1007,6 +1008,7 @@ fFlags = [
( "do-eta-reduction", Opt_DoEtaReduction ),
( "case-merge", Opt_CaseMerge ),
( "unbox-strict-fields", Opt_UnboxStrictFields ),
( "dicts-cheap", Opt_DictsCheap ),
( "excess-precision", Opt_ExcessPrecision ),
( "asm-mangling", Opt_DoAsmMangling )
]
......
......@@ -25,7 +25,7 @@ module SimplUtils (
import SimplEnv
import DynFlags ( SimplifierSwitch(..), SimplifierMode(..),
DynFlag(..), dopt )
DynFlags, DynFlag(..), dopt )
import StaticFlags ( opt_UF_UpdateInPlace, opt_SimplNoPreInlining,
opt_RulesOff )
import CoreSyn
......@@ -818,7 +818,7 @@ mkLam env bndrs body cont
| dopt Opt_DoLambdaEtaExpansion dflags,
any isRuntimeVar bndrs
= tryEtaExpansion body `thenSmpl` \ body' ->
= tryEtaExpansion dflags body `thenSmpl` \ body' ->
returnSmpl (emptyFloats env, mkLams bndrs body')
{- Sept 01: I'm experimenting with getting the
......@@ -901,13 +901,13 @@ when computing arity; and etaExpand adds the coerces as necessary when
actually computing the expansion.
\begin{code}
tryEtaExpansion :: OutExpr -> SimplM OutExpr
tryEtaExpansion :: DynFlags -> OutExpr -> SimplM OutExpr
-- There is at least one runtime binder in the binders
tryEtaExpansion body
tryEtaExpansion dflags body
= getUniquesSmpl `thenSmpl` \ us ->
returnSmpl (etaExpand fun_arity us body (exprType body))
where
fun_arity = exprEtaExpandArity body
fun_arity = exprEtaExpandArity dflags body
\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