[commit: ghc] master: Turn infinite loop into a panic (db6f1d9)

[git at git.haskell.org]

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

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

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

commit db6f1d9cfc74690798645a7cc5b25040c36bb35d
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Wed Aug 22 09:51:26 2018 +0100

    Turn infinite loop into a panic
    
    In these two functions
      * TcIface.toIfaceAppTyArgsX
      * Type.piResultTys
    we take a type application (f t1 .. tn) and try to find
    its kind. It turned out that, if (f t1 .. tn) was ill-kinded
    the function would go into an infinite loop.
    
    That's not good: it caused the loop in Trac #15473.
    
    This patch doesn't fix the bug in #15473, but it does turn the
    loop into a decent panic, which is a step forward.


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

db6f1d9cfc74690798645a7cc5b25040c36bb35d
 compiler/iface/ToIface.hs | 15 ++++++++++++---
 compiler/types/Type.hs    | 14 ++++++++++----
 2 files changed, 22 insertions(+), 7 deletions(-)

diff --git a/compiler/iface/ToIface.hs b/compiler/iface/ToIface.hs
index 8452b8b..0b0782d 100644
--- a/compiler/iface/ToIface.hs
+++ b/compiler/iface/ToIface.hs
@@ -305,11 +305,20 @@ toIfaceAppArgsX fr kind ty_args
     go env (FunTy _ res) (t:ts) -- No type-class args in tycon apps
       = IA_Vis (toIfaceTypeX fr t) (go env res ts)
 
-    go env ty ts = ASSERT2( not (isEmptyTCvSubst env)
-                          , ppr kind $$ ppr ty_args )
-                   go (zapTCvSubst env) (substTy env ty) ts
+    go env ty ts@(t1:ts1)
+      | not (isEmptyTCvSubst env)
+      = go (zapTCvSubst env) (substTy env ty) ts
         -- See Note [Care with kind instantiation] in Type.hs
 
+      | otherwise
+      = -- There's a kind error in the type we are trying to print
+        -- e.g. kind = k, ty_args = [Int]
+        -- This is probably a compiler bug, so we print a trace and
+        -- carry on as if it were FunTy.  Without the test for
+        -- isEmptyTCvSubst we'd get an infinite loop (Trac #15473)
+        WARN( True, ppr kind $$ ppr ty_args )
+        IA_Vis (toIfaceTypeX fr t1) (go env ty ts1)
+
 tidyToIfaceType :: TidyEnv -> Type -> IfaceType
 tidyToIfaceType env ty = toIfaceType (tidyType env ty)
 
diff --git a/compiler/types/Type.hs b/compiler/types/Type.hs
index 4f0bcf8..9b4aec6 100644
--- a/compiler/types/Type.hs
+++ b/compiler/types/Type.hs
@@ -1048,13 +1048,19 @@ piResultTys ty orig_args@(arg:args)
       | ForAllTy (TvBndr tv _) res <- ty
       = go (extendVarEnv tv_env tv arg) res args
 
-      | otherwise  -- See Note [Care with kind instantiation]
-      = ASSERT2( not (isEmptyVarEnv tv_env)
-               , ppr ty $$ ppr orig_args $$ ppr all_args )
-        go emptyTvSubstEnv
+      | not (isEmptyVarEnv tv_env)  -- See Note [Care with kind instantiation]
+      = go emptyTvSubstEnv
           (substTy (mkTvSubst in_scope tv_env) ty)
           all_args
 
+      | otherwise
+      = -- We have not run out of arguments, but the function doesn't
+        -- have the right kind to apply to them; so panic.
+        -- Without hte explicit isEmptyVarEnv test, an ill-kinded type
+        -- would give an infniite loop, which is very unhelpful
+        -- c.f. Trac #15473
+        pprPanic "piResultTys2" (ppr ty $$ ppr orig_args $$ ppr all_args)
+
 applyTysX :: [TyVar] -> Type -> [Type] -> Type
 -- applyTyxX beta-reduces (/\tvs. body_ty) arg_tys
 -- Assumes that (/\tvs. body_ty) is closed