X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypes%2FVariance.lhs;h=5f4b3f64c8b4121b70a7edcc1beeab9aaa99155f;hb=95581e0c3b2d4d6edd33fdd6e135aa3917072c4c;hp=52f5d0873dd2909d4f63bd9e147b6e922fb62c03;hpb=111cee3f1ad93816cb828e38b38521d85c3bcebb;p=ghc-hetmet.git

diff --git a/ghc/compiler/types/Variance.lhs b/ghc/compiler/types/Variance.lhs
index 52f5d08..5f4b3f6 100644
--- a/ghc/compiler/types/Variance.lhs
+++ b/ghc/compiler/types/Variance.lhs
@@ -12,16 +12,15 @@ module Variance(
 #include "HsVersions.h"
 
 import TypeRep          ( Type(..), TyNote(..) )  -- friend
-import Type             ( mkDictTy )
-import TyCon            ( TyCon, ArgVrcs, tyConKind, tyConArity, tyConDataCons, tyConTyVars,
+import TyCon            ( TyCon, ArgVrcs, tyConArity, tyConDataCons_maybe, tyConDataCons, tyConTyVars,
                           tyConArgVrcs_maybe, getSynTyConDefn, isSynTyCon, isAlgTyCon )
 import DataCon          ( dataConRepArgTys )
 
 import FiniteMap
 import Var              ( TyVar )
 import VarSet
-import Name             ( Name, getName )
 import Maybes           ( expectJust )
+import Maybe		( isNothing )
 import Outputable
 \end{code}
 
@@ -41,21 +40,19 @@ tycons as a whole.  It returns a list of @tyconVrcInfo@ data, ready to
 be (knot-tyingly?) stuck back into the appropriate fields.
 
 \begin{code}
-calcTyConArgVrcs :: [TyCon]
-		 -> FiniteMap Name ArgVrcs
+calcTyConArgVrcs :: [TyCon] -> FiniteMap TyCon ArgVrcs
 
 calcTyConArgVrcs tycons
-  = let oi           = foldl (\fm tc -> addToFM fm tc (initial tc)) emptyFM tycons
-        initial tc   = if isAlgTyCon tc && null (tyConDataCons tc) then
+  = tcaoFix initial_oi
+  where
+
+    initial_oi :: FiniteMap TyCon ArgVrcs
+    initial_oi   = foldl (\fm tc -> addToFM fm tc (initial tc)) emptyFM tycons
+    initial tc   = if isAlgTyCon tc && isNothing (tyConDataCons_maybe tc) then
                          -- make pessimistic assumption (and warn)
-                         take (tyConArity tc) abstractVrcs
+                         abstractVrcs tc
                        else
                          replicate (tyConArity tc) (False,False)
-        oi''         = tcaoFix oi
-        go (tc,vrcs) = (getName tc,vrcs)
-    in  listToFM (map go (fmToList oi''))
-        
-  where
 
     tcaoFix :: FiniteMap TyCon ArgVrcs   -- initial ArgVrcs per tycon
 	    -> FiniteMap TyCon ArgVrcs   -- fixpointed ArgVrcs per tycon
@@ -76,15 +73,20 @@ calcTyConArgVrcs tycons
 	     -> ArgVrcs                  -- new ArgVrcs for tycon
 
     tcaoIter oi tc | isAlgTyCon tc
-      = let cs        = tyConDataCons tc
-            vs        = tyConTyVars tc
-	    argtys    = concatMap dataConRepArgTys cs
-	    myfao tc  = lookupWithDefaultFM oi (expectJust "tcaoIter(Alg)" $
-                                                  tyConArgVrcs_maybe tc)
-                                               tc
-                        -- we use the already-computed result for tycons not in this SCC
-        in  map (\v -> anyVrc (\ty -> vrcInTy myfao v ty) argtys)
+      = if null data_cons then
+		-- Abstract types get uninformative variances
+	    abstractVrcs tc
+	else
+            map (\v -> anyVrc (\ty -> vrcInTy myfao v ty) argtys)
                 vs
+      where
+       	data_cons = tyConDataCons tc
+       	vs        = tyConTyVars tc
+       	argtys    = concatMap dataConRepArgTys data_cons
+       	myfao tc  = lookupWithDefaultFM oi (expectJust "tcaoIter(Alg)" $
+       						   tyConArgVrcs_maybe tc)
+       					   tc
+       			 -- we use the already-computed result for tycons not in this SCC
 
     tcaoIter oi tc | isSynTyCon tc
       = let (tyvs,ty) = getSynTyConDefn tc
@@ -95,11 +97,18 @@ calcTyConArgVrcs tycons
         in  map (\v -> vrcInTy myfao v ty) tyvs
 
 
-abstractVrcs :: ArgVrcs
--- we pull this out as a CAF so the warning only appears *once*
-abstractVrcs = trace ("WARNING: tyConArgVrc info inaccurate due to unavailable constructors.\n"
-                      ++ "\tUse -fno-prune-tydecls to fix.") $
-                 repeat (True,True)
+abstractVrcs :: TyCon -> ArgVrcs
+abstractVrcs tc = 
+#ifdef DEBUG
+                  pprTrace "Vrc: abstract tycon:" (ppr tc) $
+#endif
+                  warn_abstract_vrcs `seq` replicate (tyConArity tc) (True,True)
+
+warn_abstract_vrcs
+-- we pull the message out as a CAF so the warning only appears *once*
+  = trace ("WARNING: tyConArgVrc info inaccurate due to unavailable constructors.\n"
+        ++ "         Use -fno-prune-tydecls to fix.") $
+                ()
 \end{code}
 
 
@@ -117,10 +126,6 @@ vrcInTy :: (TyCon -> ArgVrcs)  -- function to get argVrcs of a tycon (break out
         -> Type                -- type to check for occ in
         -> (Bool,Bool)         -- (occurs positively, occurs negatively)
 
-vrcInTy fao v (NoteTy (UsgNote _)   ty) = vrcInTy fao v ty
-
-vrcInTy fao v (NoteTy (UsgForAll _) ty) = vrcInTy fao v ty
-
 vrcInTy fao v (NoteTy (SynNote _)   ty) = vrcInTy fao v ty
     			-- SynTyCon doesn't neccessarily have vrcInfo at this point,
     			-- so don't try and use it
@@ -143,9 +148,9 @@ vrcInTy fao v (AppTy ty1 ty2)           = if vrcInTy fao v ty2 /= (False,False)
                         -- hence if v occurs in ty2 at all then it could occur with
                         -- either variance.  Otherwise it occurs as it does in ty1.
 
-vrcInTy fao v (FunTy ty1 ty2)           = let (p1,m1) = vrcInTy fao v ty1
-    					      (p2,m2) = vrcInTy fao v ty2
-    					  in (m1||p2,p1||m2)
+vrcInTy fao v (FunTy ty1 ty2)           = negVrc (vrcInTy fao v ty1)
+                                          `orVrc`
+                                          vrcInTy fao v ty2
 					 
 vrcInTy fao v (ForAllTy v' ty)          = if v==v'
 					  then (False,False)
@@ -178,6 +183,9 @@ orVrc (p1,m1) (p2,m2) = (p1||p2,m1||m2)
 orVrcs :: [(Bool,Bool)] -> (Bool,Bool)
 orVrcs = foldl orVrc (False,False)
 
+negVrc :: (Bool,Bool) -> (Bool,Bool)
+negVrc (p1,m1) = (m1,p1)
+
 anyVrc :: (a -> (Bool,Bool)) -> [a] -> (Bool,Bool)
 anyVrc p as = foldl (\ pm a -> pm `orVrc` p a)
                     (False,False) as