[commit: ghc] wip/callArityExprIsCheap: CallArity: Use exprIsCheap to detect thunks (0f5b9a6)
git at git.haskell.org
git at git.haskell.org
Mon Dec 26 09:29:17 UTC 2016
Repository : ssh://git@git.haskell.org/ghc
On branch : wip/callArityExprIsCheap
Link : http://ghc.haskell.org/trac/ghc/changeset/0f5b9a6509ebd7176f11b8995043a77243f45612/ghc
>---------------------------------------------------------------
commit 0f5b9a6509ebd7176f11b8995043a77243f45612
Author: Joachim Breitner <mail at joachim-breitner.de>
Date: Mon Dec 26 10:16:55 2016 +0100
CallArity: Use exprIsCheap to detect thunks
Originally, everything that is not in WHNF (`exprIsWHNF`) is considered
a thunk, not eta-expanded, to avoid losing any sharing. This is also how
the published papers on Call Arity describe it.
In practice, there are thunks that do a just little work, such as
pattern-matching on a variable, and the benefits of eta-expansion likely
oughtweigh the cost of doing that repeatedly. Therefore, this
implementation of Call Arity considers everything that is not cheap
(`exprIsCheap`) as a thunk.
>---------------------------------------------------------------
0f5b9a6509ebd7176f11b8995043a77243f45612
compiler/simplCore/CallArity.hs | 19 +++++++++++++++----
testsuite/tests/callarity/unittest/CallArity1.hs | 11 ++++++-----
2 files changed, 21 insertions(+), 9 deletions(-)
diff --git a/compiler/simplCore/CallArity.hs b/compiler/simplCore/CallArity.hs
index 3bd6a43..b703c07 100644
--- a/compiler/simplCore/CallArity.hs
+++ b/compiler/simplCore/CallArity.hs
@@ -15,7 +15,7 @@ import BasicTypes
import CoreSyn
import Id
import CoreArity ( typeArity )
-import CoreUtils ( exprIsHNF, exprIsTrivial )
+import CoreUtils ( exprIsCheap, exprIsTrivial )
--import Outputable
import UnVarGraph
import Demand
@@ -192,7 +192,7 @@ Using the result: Eta-Expansion
We use the result of these two analyses to decide whether we can eta-expand the
rhs of a let-bound variable.
-If the variable is already a function (exprIsHNF), and all calls to the
+If the variable is already a function (exprIsCheap), and all calls to the
variables have a higher arity than the current manifest arity (i.e. the number
of lambdas), expand.
@@ -395,6 +395,17 @@ the case for Core!
arguments mentioned in the strictness signature.
See #10176 for a real-world-example.
+Note [What is a thunk]
+~~~~~~~~~~~~~~~~~~~~~~
+
+Originally, everything that is not in WHNF (`exprIsWHNF`) is considered a
+thunk, not eta-expanded, to avoid losing any sharing. This is also how the
+published papers on Call Arity describe it.
+
+In practice, there are thunks that do a just little work, such as
+pattern-matching on a variable, and the benefits of eta-expansion likely
+oughtweigh the cost of doing that repeatedly. Therefore, this implementation of
+Call Arity considers everything that is not cheap (`exprIsCheap`) as a thunk.
-}
-- Main entry point
@@ -533,7 +544,7 @@ callArityBind boring_vars ae_body int (NonRec v rhs)
-- (vcat [ppr v, ppr ae_body, ppr int, ppr ae_rhs, ppr safe_arity])
(final_ae, NonRec v' rhs')
where
- is_thunk = not (exprIsHNF rhs)
+ is_thunk = not (exprIsCheap rhs) -- see note [What is a thunk]
-- If v is boring, we will not find it in ae_body, but always assume (0, False)
boring = v `elemVarSet` boring_vars
@@ -603,7 +614,7 @@ callArityBind boring_vars ae_body int b@(Rec binds)
| otherwise
-- We previously analized this with a different arity (or not at all)
- = let is_thunk = not (exprIsHNF rhs)
+ = let is_thunk = not (exprIsCheap rhs) -- see note [What is a thunk]
safe_arity | is_thunk = 0 -- See Note [Thunks in recursive groups]
| otherwise = new_arity
diff --git a/testsuite/tests/callarity/unittest/CallArity1.hs b/testsuite/tests/callarity/unittest/CallArity1.hs
index 6873d32..88f83fd 100644
--- a/testsuite/tests/callarity/unittest/CallArity1.hs
+++ b/testsuite/tests/callarity/unittest/CallArity1.hs
@@ -24,9 +24,9 @@ import CoreLint
import FastString
-- Build IDs. use mkTemplateLocal, more predictable than proper uniques
-go, go2, x, d, n, y, z, scrut :: Id
-[go, go2, x,d, n, y, z, scrut, f] = mkTestIds
- (words "go go2 x d n y z scrut f")
+go, go2, x, d, n, y, z, scrutf, scruta :: Id
+[go, go2, x,d, n, y, z, scrutf, scruta, f] = mkTestIds
+ (words "go go2 x d n y z scrutf scruta f")
[ mkFunTys [intTy, intTy] intTy
, mkFunTys [intTy, intTy] intTy
, intTy
@@ -34,6 +34,7 @@ go, go2, x, d, n, y, z, scrut :: Id
, mkFunTys [intTy] intTy
, intTy
, intTy
+ , mkFunTys [boolTy] boolTy
, boolTy
, mkFunTys [intTy, intTy] intTy -- protoypical external function
]
@@ -168,7 +169,7 @@ main = do
getSessionDynFlags >>= setSessionDynFlags . flip gopt_set Opt_SuppressUniques
dflags <- getSessionDynFlags
liftIO $ forM_ exprs $ \(n,e) -> do
- case lintExpr dflags [f,scrut] e of
+ case lintExpr dflags [f,scrutf,scruta] e of
Just msg -> putMsg dflags (msg $$ text "in" <+> text n)
Nothing -> return ()
putMsg dflags (text n <> char ':')
@@ -184,7 +185,7 @@ main = do
mkLApps :: Id -> [Integer] -> CoreExpr
mkLApps v = mkApps (Var v) . map mkLit
-mkACase = mkIfThenElse (Var scrut)
+mkACase = mkIfThenElse (mkVarApps (Var scrutf) [scruta])
mkTestId :: Int -> String -> Type -> Id
mkTestId i s ty = mkSysLocal (mkFastString s) (mkBuiltinUnique i) ty
More information about the ghc-commits
mailing list