Add a flag -fno-state-hack, which switches off the "state hack".
It's claims that every function over realWorldStatePrimTy is a
one-shot function. This is pretty true in practice, and makes a big
difference. For example, consider
a `thenST` \ r -> ...E...
The early full laziness pass, if it doesn't know that r is one-shot
will pull out E (let's say it doesn't mention r) to give
let lvl = E in a `thenST` \ r -> ...lvl...
When `thenST` gets inlined, we end up with
let lvl = E in \s -> case a s of (r, s') -> ...lvl...
and we don't re-inline E.
-- One shot lambda stuff
- isOneShotLambda, setOneShotLambda, clearOneShotLambda,
+ isOneShotBndr, isOneShotLambda, setOneShotLambda, clearOneShotLambda,
-- IdInfo stuff
setIdUnfolding,
globalIdDetails
)
import qualified Var ( mkLocalId, mkGlobalId, mkSpecPragmaId, mkExportedLocalId )
-import Type ( Type, typePrimRep, addFreeTyVars, seqType)
-
+import Type ( Type, typePrimRep, addFreeTyVars, seqType, splitTyConApp_maybe )
+import TysPrim ( statePrimTyCon )
import IdInfo
#ifdef OLD_STRICTNESS
import SrcLoc ( SrcLoc )
import Outputable
import Unique ( Unique, mkBuiltinUnique )
+import CmdLineOpts ( opt_NoStateHack )
-- infixl so you can say (id `set` a `set` b)
infixl 1 `setIdUnfolding`,
idLBVarInfo :: Id -> LBVarInfo
idLBVarInfo id = lbvarInfo (idInfo id)
+isOneShotBndr :: Id -> Bool
+-- This one is the "business end", called externally.
+-- Its main purpose is to encapsulate the Horrible State Hack
+isOneShotBndr id = isOneShotLambda id || (isStateHack id)
+
+isStateHack id
+ | opt_NoStateHack
+ = False
+ | otherwise
+ = case splitTyConApp_maybe (idType id) of
+ Just (tycon,_) | tycon == statePrimTyCon -> True
+ other -> False
+ -- This is a gross hack. It claims that
+ -- every function over realWorldStatePrimTy is a one-shot
+ -- function. This is pretty true in practice, and makes a big
+ -- difference. For example, consider
+ -- a `thenST` \ r -> ...E...
+ -- The early full laziness pass, if it doesn't know that r is one-shot
+ -- will pull out E (let's say it doesn't mention r) to give
+ -- let lvl = E in a `thenST` \ r -> ...lvl...
+ -- When `thenST` gets inlined, we end up with
+ -- let lvl = E in \s -> case a s of (r, s') -> ...lvl...
+ -- and we don't re-inline E.
+ --
+ -- It would be better to spot that r was one-shot to start with, but
+ -- I don't want to rely on that.
+ --
+ -- Another good example is in fill_in in PrelPack.lhs. We should be able to
+ -- spot that fill_in has arity 2 (and when Keith is done, we will) but we can't yet.
+
+
+-- The OneShotLambda functions simply fiddle with the IdInfo flag
isOneShotLambda :: Id -> Bool
isOneShotLambda id = case idLBVarInfo id of
IsOneShotLambda -> True
import PrimOp ( PrimOp(..), primOpOkForSpeculation, primOpIsCheap )
import Id ( Id, idType, globalIdDetails, idNewStrictness,
mkWildId, idArity, idName, idUnfolding, idInfo,
- isOneShotLambda, isDataConWorkId_maybe, mkSysLocal,
+ isOneShotBndr, isDataConWorkId_maybe, mkSysLocal,
isDataConWorkId, isBottomingId
)
import IdInfo ( GlobalIdDetails(..), megaSeqIdInfo )
import Outputable
import TysPrim ( alphaTy ) -- Debugging only
import Util ( equalLength, lengthAtLeast )
-import TysPrim ( statePrimTyCon )
\end{code}
and the \s is a real-world state token abstraction. Such abstractions
are almost invariably 1-shot, so we want to pull the \s out, past the
let x=E, even if E is expensive. So we treat state-token lambdas as
-one-shot even if they aren't really. The hack is in Id.isOneShotLambda.
+one-shot even if they aren't really. The hack is in Id.isOneShotBndr.
3. Dealing with bottom
-- use the idinfo here
-- Lambdas; increase arity
-arityType (Lam x e) | isId x = AFun (isOneShotLambda x || isStateHack x) (arityType e)
+arityType (Lam x e) | isId x = AFun (isOneShotBndr x) (arityType e)
| otherwise = arityType e
-- Applications; decrease arity
arityType other = ATop
-isStateHack id = case splitTyConApp_maybe (idType id) of
- Just (tycon,_) | tycon == statePrimTyCon -> True
- other -> False
-
- -- The last clause is a gross hack. It claims that
- -- every function over realWorldStatePrimTy is a one-shot
- -- function. This is pretty true in practice, and makes a big
- -- difference. For example, consider
- -- a `thenST` \ r -> ...E...
- -- The early full laziness pass, if it doesn't know that r is one-shot
- -- will pull out E (let's say it doesn't mention r) to give
- -- let lvl = E in a `thenST` \ r -> ...lvl...
- -- When `thenST` gets inlined, we end up with
- -- let lvl = E in \s -> case a s of (r, s') -> ...lvl...
- -- and we don't re-inline E.
- --
- -- It would be better to spot that r was one-shot to start with, but
- -- I don't want to rely on that.
- --
- -- Another good example is in fill_in in PrelPack.lhs. We should be able to
- -- spot that fill_in has arity 2 (and when Keith is done, we will) but we can't yet.
-
{- NOT NEEDED ANY MORE: etaExpand is cleverer
ok_note InlineMe = False
ok_note other = True
opt_Flatten,
-- optimisation opts
- opt_NoMethodSharing,
+ opt_NoMethodSharing,
+ opt_NoStateHack,
opt_LiberateCaseThreshold,
opt_CprOff,
opt_RulesOff,
opt_Flatten = lookUp FSLIT("-fflatten")
-- optimisation opts
+opt_NoStateHack = lookUp FSLIT("-fno-state-hack")
opt_NoMethodSharing = lookUp FSLIT("-fno-method-sharing")
opt_CprOff = lookUp FSLIT("-fcpr-off")
opt_RulesOff = lookUp FSLIT("-frules-off")
import CoreUtils ( exprIsValue, exprIsDupable )
import CoreLint ( showPass, endPass )
import CoreFVs ( CoreExprWithFVs, freeVars, freeVarsOf )
-import Id ( isOneShotLambda )
+import Id ( isOneShotBndr )
import Var ( Id, idType )
import Type ( isUnLiftedType )
import VarSet
noFloatIntoRhs rhs = exprIsValue (deAnnotate' rhs) -- We'd just float right back out again...
-is_one_shot b = isId b && isOneShotLambda b
+is_one_shot b = isId b && isOneShotBndr b
\end{code}
import CoreSyn
import CoreFVs ( idRuleVars )
import CoreUtils ( exprIsTrivial )
-import Id ( isDataConWorkId, isOneShotLambda, setOneShotLambda,
+import Id ( isDataConWorkId, isOneShotBndr, setOneShotLambda,
idOccInfo, setIdOccInfo,
isExportedId, modifyIdInfo, idInfo, idArity,
idSpecialisation, isLocalId,
= case go ctxt bndrs [] of
(new_ctxt, new_bndrs) -> (all is_one_shot new_bndrs, OccEnv cands encl new_ctxt, new_bndrs)
where
- is_one_shot b = isId b && isOneShotLambda b
+ is_one_shot b = isId b && isOneShotBndr b
go ctxt [] rev_bndrs = (ctxt, reverse rev_bndrs)
projects / ghc-hetmet.git / commitdiff