Commit db6f1d9c authored by Simon Peyton Jones's avatar Simon Peyton Jones

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.
parent 44ba6652
......@@ -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)
......@@ -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)
| 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
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment