Commit c1a1488f authored by simonpj@microsoft.com's avatar simonpj@microsoft.com
Browse files

Improve the situation for Trac #959: civilised warning instead of a trace msg

This doesn't fix the root cause of the bug, but it makes the report
more civilised, and points to further info.
parent 91d5084f
......@@ -189,7 +189,9 @@ dsHsBind auto_scc rest (AbsBinds all_tyvars dicts exports binds)
mk_bind ((tyvars, global, local, prags), n) -- locals !! n == local
= -- Need to make fresh locals to bind in the selector, because
-- some of the tyvars will be bound to 'Any'
do { locals' <- newSysLocalsDs (map substitute local_tys)
do { ty_args <- mapM mk_ty_arg all_tyvars
; let substitute = substTyWith all_tyvars ty_args
; locals' <- newSysLocalsDs (map substitute local_tys)
; tup_id <- newSysLocalDs (substitute tup_ty)
; mb_specs <- mapM (dsSpec all_tyvars dicts tyvars global local core_bind)
prags
......@@ -200,10 +202,9 @@ dsHsBind auto_scc rest (AbsBinds all_tyvars dicts exports binds)
mkApps (mkTyApps (Var poly_tup_id) ty_args) dict_args
; returnDs ((global', rhs) : spec_binds) }
where
mk_ty_arg all_tyvar | all_tyvar `elem` tyvars = mkTyVarTy all_tyvar
| otherwise = mkArbitraryType all_tyvar
ty_args = map mk_ty_arg all_tyvars
substitute = substTyWith all_tyvars ty_args
mk_ty_arg all_tyvar
| all_tyvar `elem` tyvars = return (mkTyVarTy all_tyvar)
| otherwise = dsMkArbitraryType all_tyvar
; export_binds_s <- mappM mk_bind (exports `zip` [0..])
-- don't scc (auto-)annotate the tuple itself.
......@@ -271,27 +272,30 @@ dsSpec all_tvs dicts tvs poly_id mono_id mono_bind
case mb_lhs of
Nothing -> do { warnDs decomp_msg; return Nothing }
Just (var, args) -> return (Just (addInlineInfo inl spec_id spec_rhs, rule))
where
local_poly = setIdNotExported poly_id
Just (var, args) -> do
{ f_body <- fix_up (Let mono_bind (Var mono_id))
; let local_poly = setIdNotExported poly_id
-- Very important to make the 'f' non-exported,
-- else it won't be inlined!
spec_id = mkLocalId spec_name spec_ty
spec_rhs = Let (NonRec local_poly poly_f_body) ds_spec_expr
poly_f_body = mkLams (tvs ++ dicts) $
fix_up (Let mono_bind (Var mono_id))
poly_f_body = mkLams (tvs ++ dicts) f_body
rule = mkLocalRule (mkFastString ("SPEC " ++ showSDoc (ppr poly_name)))
AlwaysActive poly_name
bndrs args
(mkVarApps (Var spec_id) bndrs)
} }
; return (Just (addInlineInfo inl spec_id spec_rhs, rule))
} } }
where
-- Bind to Any any of all_ptvs that aren't
-- relevant for this particular function
fix_up body | null void_tvs = body
| otherwise = mkTyApps (mkLams void_tvs body)
(map mkArbitraryType void_tvs)
fix_up body | null void_tvs = return body
| otherwise = do { void_tys <- mapM dsMkArbitraryType void_tvs
; return (mkTyApps (mkLams void_tvs body) void_tys) }
void_tvs = all_tvs \\ tvs
dead_msg bs = vcat [ sep [ptext SLIT("Useless constraint") <> plural bs
......@@ -302,6 +306,10 @@ dsSpec all_tvs dicts tvs poly_id mono_id mono_bind
decomp_msg = hang (ptext SLIT("Specialisation too complicated to desugar; ignored"))
2 (ppr spec_expr)
dsMkArbitraryType tv = mkArbitraryType warn tv
where
warn span msg = putSrcSpanDs span (warnDs msg)
\end{code}
Note [Unused spec binders]
......
......@@ -67,6 +67,7 @@ import Type ( mkTyConApp, mkTyConTy, mkTyVarTys, mkTyVarTy,
import SrcLoc
import Unique ( mkAlphaTyVarUnique, pprUnique )
import PrelNames
import StaticFlags
import FastString ( FastString, mkFastString )
import Outputable
......@@ -311,7 +312,8 @@ anyPrimTyCon1 = mkLiftedPrimTyCon anyPrimTyCon1Name kind 0 PtrRep
mkAnyPrimTyCon :: Unique -> Kind -> TyCon
-- Grotesque hack alert: the client gives the unique; so equality won't work
mkAnyPrimTyCon uniq kind
= pprTrace "Urk! Inventing strangely-kinded Any TyCon:" (ppr uniq <+> ppr kind)
= WARN( opt_PprStyle_Debug, ptext SLIT("Urk! Inventing strangely-kinded Any TyCon:") <+> ppr uniq <+> ppr kind )
-- See Note [Strangely-kinded void TyCons] in TcHsSyn
tycon
where
name = mkPrimTc (mkFastString ("Any" ++ showSDoc (pprUnique uniq))) uniq tycon
......
......@@ -908,56 +908,76 @@ zonkTypeZapping ty
-- mutable tyvar to a fresh immutable one. So the mutable store
-- plays the role of an environment. If we come across a mutable
-- type variable that isn't so bound, it must be completely free.
zonk_unbound_tyvar tv = do { writeMetaTyVar tv ty; return ty }
where
ty = mkArbitraryType tv
-- When the type checker finds a type variable with no binding,
-- which means it can be instantiated with an arbitrary type, it
-- usually instantiates it to Void. Eg.
--
-- length []
-- ===>
-- length Void (Nil Void)
--
-- But in really obscure programs, the type variable might have
-- a kind other than *, so we need to invent a suitably-kinded type.
--
-- This commit uses
-- Void for kind *
-- List for kind *->*
-- Tuple for kind *->...*->*
--
-- which deals with most cases. (Previously, it only dealt with
-- kind *.)
--
-- In the other cases, it just makes up a TyCon with a suitable
-- kind. If this gets into an interface file, anyone reading that
-- file won't understand it. This is fixable (by making the client
-- of the interface file make up a TyCon too) but it is tiresome and
-- never happens, so I am leaving it
mkArbitraryType :: TcTyVar -> Type
-- Make up an arbitrary type whose kind is the same as the tyvar.
-- We'll use this to instantiate the (unbound) tyvar.
mkArbitraryType tv
| liftedTypeKind `isSubKind` kind = anyPrimTy -- The vastly common case
| otherwise = mkTyConApp tycon []
where
kind = tyVarKind tv
(args,res) = splitKindFunTys kind
zonk_unbound_tyvar tv = do { ty <- mkArbitraryType warn tv
; writeMetaTyVar tv ty
; return ty }
where
warn span msg = setSrcSpan span (addWarnTc msg)
{- Note [Strangely-kinded void TyCons]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
See Trac #959 for more examples
When the type checker finds a type variable with no binding, which
means it can be instantiated with an arbitrary type, it usually
instantiates it to Void. Eg.
length []
===>
length Void (Nil Void)
tycon | eqKind kind (tyConKind anyPrimTyCon1) -- *->*
= anyPrimTyCon1 -- No tuples this size
But in really obscure programs, the type variable might have a kind
other than *, so we need to invent a suitably-kinded type.
| all isLiftedTypeKind args && isLiftedTypeKind res
= tupleTyCon Boxed (length args) -- *-> ... ->*->*
-- Horrible hack to make less use of mkAnyPrimTyCon
This commit uses
Void for kind *
List for kind *->*
Tuple for kind *->...*->*
| otherwise
= mkAnyPrimTyCon (getUnique tv) kind
which deals with most cases. (Previously, it only dealt with
kind *.)
In the other cases, it just makes up a TyCon with a suitable kind. If
this gets into an interface file, anyone reading that file won't
understand it. This is fixable (by making the client of the interface
file make up a TyCon too) but it is tiresome and never happens, so I
am leaving it.
Meanwhile I have now fixed GHC to emit a civilized warning.
-}
mkArbitraryType :: (SrcSpan -> SDoc -> TcRnIf g l a) -- How to complain
-> TcTyVar
-> TcRnIf g l Type -- Used by desugarer too
-- Make up an arbitrary type whose kind is the same as the tyvar.
-- We'll use this to instantiate the (unbound) tyvar.
--
-- Also used by the desugarer; hence the (tiresome) parameter
-- to use when generating a warning
mkArbitraryType warn tv
| liftedTypeKind `isSubKind` kind -- The vastly common case
= return anyPrimTy
| eqKind kind (tyConKind anyPrimTyCon1) -- *->*
= return (mkTyConApp anyPrimTyCon1 []) -- No tuples this size
| all isLiftedTypeKind args -- *-> ... ->*->*
, isLiftedTypeKind res -- Horrible hack to make less use
= return (mkTyConApp tup_tc []) -- of mkAnyPrimTyCon
| otherwise
= do { warn (getSrcSpan tv) msg
; return (mkTyConApp (mkAnyPrimTyCon (getUnique tv) kind) []) }
-- Same name as the tyvar, apart from making it start with a colon (sigh)
-- I dread to think what will happen if this gets out into an
-- interface file. Catastrophe likely. Major sigh.
where
kind = tyVarKind tv
(args,res) = splitKindFunTys kind
tup_tc = tupleTyCon Boxed (length args)
msg = vcat [ hang (ptext SLIT("Inventing strangely-kinded Any TyCon"))
2 (ptext SLIT("of kind") <+> quotes (ppr kind))
, nest 2 (ptext SLIT("from an instantiation of type variable") <+> quotes (ppr tv))
, ptext SLIT("This warning can be suppressed by a type signature fixing") <+> quotes (ppr tv)
, nest 2 (ptext SLIT("but is harmless without -O (and usually harmless anyway)."))
, ptext SLIT("See http://hackage.haskell.org/trac/ghc/ticket/959 for details") ]
\end{code}
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