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 (file)
--- 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'
              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
                     ; 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
                                 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.
 
        ; 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 }
 
          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
                        -- 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)
                  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 
   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
     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)
 
     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]
 \end{code}
 
 Note [Unused spec binders]

diff --git a/compiler/prelude/TysPrim.lhs b/compiler/prelude/TysPrim.lhs
index 19d71db..9aa837d 100644 (file)
--- 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 SrcLoc
 import Unique          ( mkAlphaTyVarUnique, pprUnique )
 import PrelNames

+import StaticFlags

 import FastString      ( FastString, mkFastString )
 import Outputable
 
 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 
 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
     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 (file)
--- 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.
        -- 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.
                -- 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}
 \end{code}