Fix exprIsHNF (Trac #11248)
authorSimon Peyton Jones <simonpj@microsoft.com>
Mon, 25 Jan 2016 11:16:18 +0000 (11:16 +0000)
committerSimon Peyton Jones <simonpj@microsoft.com>
Mon, 25 Jan 2016 11:32:32 +0000 (11:32 +0000)
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.

compiler/coreSyn/CoreUtils.hs
testsuite/tests/polykinds/T11248.hs

index 3664d8e..eaccb33 100644 (file)
@@ -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]
index e1c8fcc..b3a32e3 100644 (file)
@@ -1,3 +1,6 @@
+{-# OPTIONS_GHC -O #-}
+  -- Trac #11248, comment:6 showed that this tests failed with -O
+
 {-# LANGUAGE DataKinds, TypeOperators, TypeFamilies,
              KindSignatures, ConstraintKinds #-}