From 74e0bdb67ea643c0586e40893bdafcbe651267ba Mon Sep 17 00:00:00 2001 From: simonpj Date: Tue, 27 Apr 2004 12:47:18 +0000 Subject: [PATCH] [project @ 2004-04-27 12:47:13 by simonpj] ---------------------------------------- 1. Make primOpIsCheap do something sensible 2. Make the state hack work better ---------------------------------------- 1. In March 2001, we changed primOpIsCheap to primOpIsCheap op = False thereby making *no* primops seem cheap. But this killed eta expansion on case (x ==# y) of True -> \s -> ... which is bad. In particular a loop like doLoop n = loop 0 where loop i | i == n = return () | otherwise = bar i >> loop (i+1) allocated a closure every time round because it didn't eta expand. The problem that made us set primOpIsCheap to False was let x = a +# b *# c in x +# x where we don't want to inline x. But primopIsCheap doesn't control that (it's exprIsDupable that does) so the problem doesn't occur even if primOpIsCheap sometimes says 'True'. I think that perhaps something changed since March 2001. 2. Consider this case x of True -> \(s:RealWorld) -> e False -> foo where foo has arity 1. If we are using the "state hack" we want to eta expand here. This commit fixes arityType in the Var case (for foo) to take account of foo's type. Also add -fno-state-hack to the static flags, to allow the state hack to be switched off. --- ghc/compiler/basicTypes/Id.lhs | 14 ++++++++------ ghc/compiler/coreSyn/CoreUtils.lhs | 28 +++++++++++++++++++--------- ghc/compiler/main/CmdLineOpts.lhs | 2 +- ghc/compiler/prelude/PrimOp.lhs | 23 +++++++++++++++++++---- 4 files changed, 47 insertions(+), 20 deletions(-) diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs index 0a34d27..8761762 100644 --- a/ghc/compiler/basicTypes/Id.lhs +++ b/ghc/compiler/basicTypes/Id.lhs @@ -38,7 +38,8 @@ module Id ( -- One shot lambda stuff - isOneShotBndr, isOneShotLambda, setOneShotLambda, clearOneShotLambda, + isOneShotBndr, isOneShotLambda, isStateHackType, + setOneShotLambda, clearOneShotLambda, -- IdInfo stuff setIdUnfolding, @@ -459,15 +460,16 @@ 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) +isOneShotBndr id = isOneShotLambda id || (isStateHackType (idType id)) -isStateHack id +isStateHackType :: Type -> Bool +isStateHackType ty | opt_NoStateHack = False | otherwise - = case splitTyConApp_maybe (idType id) of - Just (tycon,_) | tycon == statePrimTyCon -> True - other -> False + = case splitTyConApp_maybe ty of + Just (tycon,_) -> tycon == statePrimTyCon + 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 diff --git a/ghc/compiler/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs index 54fcbb6..4c148cc 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, - isOneShotBndr, isDataConWorkId_maybe, mkSysLocal, + isOneShotBndr, isStateHackType, isDataConWorkId_maybe, mkSysLocal, isDataConWorkId, isBottomingId ) import IdInfo ( GlobalIdDetails(..), megaSeqIdInfo ) @@ -770,15 +770,25 @@ arityType (Note n e) = arityType e -- | otherwise = ATop arityType (Var v) - = mk (idArity v) + = mk (idArity v) (arg_tys (idType v)) where - mk :: Arity -> ArityType - mk 0 | isBottomingId v = ABot - | otherwise = ATop - mk n = AFun False (mk (n-1)) - - -- When the type of the Id encodes one-shot-ness, - -- use the idinfo here + mk :: Arity -> [Type] -> ArityType + -- The argument types are only to steer the "state hack" + -- Consider case x of + -- True -> foo + -- False -> \(s:RealWorld) -> e + -- where foo has arity 1. Then we want the state hack to + -- apply to foo too, so we can eta expand the case. + mk 0 tys | isBottomingId v = ABot + | otherwise = ATop + mk n (ty:tys) = AFun (isStateHackType ty) (mk (n-1) tys) + mk n [] = AFun False (mk (n-1) []) + + arg_tys :: Type -> [Type] -- Ignore for-alls + arg_tys ty + | Just (_, ty') <- splitForAllTy_maybe ty = arg_tys ty' + | Just (arg,res) <- splitFunTy_maybe ty = arg : arg_tys res + | otherwise = [] -- Lambdas; increase arity arityType (Lam x e) | isId x = AFun (isOneShotBndr x) (arityType e) diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs index 6d8a2bf..6861620 100644 --- a/ghc/compiler/main/CmdLineOpts.lhs +++ b/ghc/compiler/main/CmdLineOpts.lhs @@ -845,11 +845,11 @@ isStaticHscFlag f = "fno-hi-version-check", "dno-black-holing", "fno-method-sharing", + "fno-state-hack", "fruntime-types", "fno-pre-inlining", "fexcess-precision", "funfolding-update-in-place", - "fno-prune-decls", "static", "funregisterised", "fext-core", diff --git a/ghc/compiler/prelude/PrimOp.lhs b/ghc/compiler/prelude/PrimOp.lhs index 81c91cc..6dc4ec1 100644 --- a/ghc/compiler/prelude/PrimOp.lhs +++ b/ghc/compiler/prelude/PrimOp.lhs @@ -321,13 +321,28 @@ primOpIsCheap @primOpIsCheap@, as used in \tr{SimplUtils.lhs}. For now (HACK WARNING), we just borrow some other predicates for a what-should-be-good-enough test. "Cheap" means willing to call it more -than once. Evaluation order is unaffected. +than once, and/or push it inside a lambda. The latter could change the +behaviour of 'seq' for primops that can fail, so we don't treat them as cheap. \begin{code} primOpIsCheap :: PrimOp -> Bool -primOpIsCheap op = False - -- March 2001: be less eager to inline PrimOps - -- Was: not (primOpHasSideEffects op || primOpOutOfLine op) +primOpIsCheap op = primOpOkForSpeculation op +-- In March 2001, we changed this to +-- primOpIsCheap op = False +-- thereby making *no* primops seem cheap. But this killed eta +-- expansion on case (x ==# y) of True -> \s -> ... +-- which is bad. In particular a loop like +-- doLoop n = loop 0 +-- where +-- loop i | i == n = return () +-- | otherwise = bar i >> loop (i+1) +-- allocated a closure every time round because it doesn't eta expand. +-- +-- The problem that originally gave rise to the change was +-- let x = a +# b *# c in x +# x +-- were we don't want to inline x. But primopIsCheap doesn't control +-- that (it's exprIsDupable that does) so the problem doesn't occur +-- even if primOpIsCheap sometimes says 'True'. \end{code} primOpIsDupable -- 1.7.10.4