From: simonpj@microsoft.com Date: Mon, 19 Nov 2007 12:29:38 +0000 (+0000) Subject: Improve the situation for Trac #959: civilised warning instead of a trace msg X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=c1a1488fab7e40bdb269fcd6bfa1e547a8a562a1 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. --- diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs index 3f66158..f038773 100644 --- a/compiler/deSugar/DsBinds.lhs +++ b/compiler/deSugar/DsBinds.lhs @@ -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] diff --git a/compiler/prelude/TysPrim.lhs b/compiler/prelude/TysPrim.lhs index 19d71db..9aa837d 100644 --- a/compiler/prelude/TysPrim.lhs +++ b/compiler/prelude/TysPrim.lhs @@ -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 diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs index ec93e84..b9a2188 100644 --- a/compiler/typecheck/TcHsSyn.lhs +++ b/compiler/typecheck/TcHsSyn.lhs @@ -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}