[commit: ghc] master: Fix exprIsHNF (Trac #11248) (3c060f3)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/3c060f36f6eb4d359f252168e2f97b573d017080/ghc

>---------------------------------------------------------------

commit 3c060f36f6eb4d359f252168e2f97b573d017080
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Mon Jan 25 11:16:18 2016 +0000

    Fix exprIsHNF (Trac #11248)
    
    Blimey!  CoreUtils.exprIsHNFlike had not one but two bugs.
    
     * is_hnf_like treated coercion args like type args
       (result: exprIsHNF might wrongly say True)
    
     * app_is_value treated type args like value args
       (result: exprIsHNF might wrongly say False)
    
    Bizarre.  This goes back to at least 2012. It's amazing that it
    hasn't caused more trouble.
    
    It was discovered by a Lint error when compiling Trac #11248 with -O.


>---------------------------------------------------------------

3c060f36f6eb4d359f252168e2f97b573d017080
 compiler/coreSyn/CoreUtils.hs       | 31 +++++++++++++++++--------------
 testsuite/tests/polykinds/T11248.hs |  3 +++
 2 files changed, 20 insertions(+), 14 deletions(-)

diff --git a/compiler/coreSyn/CoreUtils.hs b/compiler/coreSyn/CoreUtils.hs
index 3664d8e..eaccb33 100644
--- a/compiler/coreSyn/CoreUtils.hs
+++ b/compiler/coreSyn/CoreUtils.hs
@@ -1459,22 +1459,25 @@ exprIsHNFlike is_con is_con_unf = is_hnf_like
     is_hnf_like (Tick tickish e) = not (tickishCounts tickish)
                                       && is_hnf_like e
                                       -- See Note [exprIsHNF Tick]
-    is_hnf_like (Cast e _)           = is_hnf_like e
-    is_hnf_like (App e (Type _))     = is_hnf_like e
-    is_hnf_like (App e (Coercion _)) = is_hnf_like e
-    is_hnf_like (App e a)            = app_is_value e [a]
-    is_hnf_like (Let _ e)            = is_hnf_like e  -- Lazy let(rec)s don't affect us
-    is_hnf_like _                    = False
+    is_hnf_like (Cast e _)       = is_hnf_like e
+    is_hnf_like (App e a)
+      | isValArg a               = app_is_value e 1
+      | otherwise                = is_hnf_like e
+    is_hnf_like (Let _ e)        = is_hnf_like e  -- Lazy let(rec)s don't affect us
+    is_hnf_like _                = False
 
     -- There is at least one value argument
-    app_is_value :: CoreExpr -> [CoreArg] -> Bool
-    app_is_value (Var fun) args
-      = idArity fun > valArgCount args    -- Under-applied function
-        || is_con fun                     --  or constructor-like
-    app_is_value (Tick _ f) as = app_is_value f as
-    app_is_value (Cast f _) as = app_is_value f as
-    app_is_value (App f a)  as = app_is_value f (a:as)
-    app_is_value _          _  = False
+    -- 'n' is number of value args to which the expression is applied
+    app_is_value :: CoreExpr -> Int -> Bool
+    app_is_value (Var fun) n_val_args
+      = idArity fun > n_val_args    -- Under-applied function
+        || is_con fun               --  or constructor-like
+    app_is_value (Tick _ f) nva = app_is_value f nva
+    app_is_value (Cast f _) nva = app_is_value f nva
+    app_is_value (App f a)  nva
+      | isValArg a              = app_is_value f (nva + 1)
+      | otherwise               = app_is_value f nva
+    app_is_value _ _ = False
 
 {-
 Note [exprIsHNF Tick]
diff --git a/testsuite/tests/polykinds/T11248.hs b/testsuite/tests/polykinds/T11248.hs
index e1c8fcc..b3a32e3 100644
--- a/testsuite/tests/polykinds/T11248.hs
+++ b/testsuite/tests/polykinds/T11248.hs
@@ -1,3 +1,6 @@
+{-# OPTIONS_GHC -O #-}
+  -- Trac #11248, comment:6 showed that this tests failed with -O
+
 {-# LANGUAGE DataKinds, TypeOperators, TypeFamilies,
              KindSignatures, ConstraintKinds #-}