From 52276d816ccaf9eef0fbd9c74833d6fd95b38cd8 Mon Sep 17 00:00:00 2001 From: simonpj Date: Fri, 2 Apr 2004 13:34:46 +0000 Subject: [PATCH] [project @ 2004-04-02 13:34:42 by simonpj] 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. --- ghc/compiler/basicTypes/Id.lhs | 39 +++++++++++++++++++++++++++++++--- ghc/compiler/coreSyn/CoreUtils.lhs | 29 +++---------------------- ghc/compiler/main/CmdLineOpts.lhs | 4 +++- ghc/compiler/simplCore/FloatIn.lhs | 4 ++-- ghc/compiler/simplCore/OccurAnal.lhs | 4 ++-- 5 files changed, 46 insertions(+), 34 deletions(-) diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs index 7cda319..0a34d27 100644 --- a/ghc/compiler/basicTypes/Id.lhs +++ b/ghc/compiler/basicTypes/Id.lhs @@ -38,7 +38,7 @@ module Id ( -- One shot lambda stuff - isOneShotLambda, setOneShotLambda, clearOneShotLambda, + isOneShotBndr, isOneShotLambda, setOneShotLambda, clearOneShotLambda, -- IdInfo stuff setIdUnfolding, @@ -89,8 +89,8 @@ import Var ( Id, DictId, 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 @@ -110,6 +110,7 @@ import Maybes ( orElse ) 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`, @@ -455,6 +456,38 @@ modifyInlinePragma id fn = modifyIdInfo (\info -> info `setInlinePragInfo` (fn ( 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 diff --git a/ghc/compiler/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs index 39d2fcf..54fcbb6 100644 --- a/ghc/compiler/coreSyn/CoreUtils.lhs +++ b/ghc/compiler/coreSyn/CoreUtils.lhs @@ -51,7 +51,7 @@ import DataCon ( DataCon, dataConRepArity, dataConArgTys, 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 ) @@ -71,7 +71,6 @@ import Unique ( Unique ) import Outputable import TysPrim ( alphaTy ) -- Debugging only import Util ( equalLength, lengthAtLeast ) -import TysPrim ( statePrimTyCon ) \end{code} @@ -715,7 +714,7 @@ IO state transformers, where we often get 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 @@ -782,7 +781,7 @@ arityType (Var v) -- 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 @@ -810,28 +809,6 @@ arityType (Let b e) = case arityType e of 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 diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs index c55f322..6d8a2bf 100644 --- a/ghc/compiler/main/CmdLineOpts.lhs +++ b/ghc/compiler/main/CmdLineOpts.lhs @@ -65,7 +65,8 @@ module CmdLineOpts ( opt_Flatten, -- optimisation opts - opt_NoMethodSharing, + opt_NoMethodSharing, + opt_NoStateHack, opt_LiberateCaseThreshold, opt_CprOff, opt_RulesOff, @@ -767,6 +768,7 @@ opt_SMP = lookUp FSLIT("-fsmp") 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") diff --git a/ghc/compiler/simplCore/FloatIn.lhs b/ghc/compiler/simplCore/FloatIn.lhs index 1967fe7..a4002a5 100644 --- a/ghc/compiler/simplCore/FloatIn.lhs +++ b/ghc/compiler/simplCore/FloatIn.lhs @@ -21,7 +21,7 @@ import CoreSyn 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 @@ -357,7 +357,7 @@ noFloatIntoRhs (AnnLam b _) = not (is_one_shot b) 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} diff --git a/ghc/compiler/simplCore/OccurAnal.lhs b/ghc/compiler/simplCore/OccurAnal.lhs index ae09f03..13bd973 100644 --- a/ghc/compiler/simplCore/OccurAnal.lhs +++ b/ghc/compiler/simplCore/OccurAnal.lhs @@ -20,7 +20,7 @@ module OccurAnal ( 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, @@ -859,7 +859,7 @@ oneShotGroup (OccEnv cands encl ctxt) bndrs = 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) -- 1.7.10.4