CallArity: Use exprIsCheap to detect thunkswip/callArityExprIsCheap

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.

2 files changed, 21 insertions, 9 deletions

diff --git a/compiler/simplCore/CallArity.hs b/compiler/simplCore/CallArity.hs
index 3bd6a43700..b703c07975 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 6873d32dd0..88f83fd7ed 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