Rewrite the unsafe code dealing with unboxed primitives in RtClosureInspect

[ghc-hetmet.git] / compiler / types / FamInstEnv.lhs

diff --git a/compiler/types/FamInstEnv.lhs b/compiler/types/FamInstEnv.lhs
index c44c200..b8c82f8 100644 (file)
--- a/compiler/types/FamInstEnv.lhs
+++ b/compiler/types/FamInstEnv.lhs
@@ -6,18 +6,22 @@ FamInstEnv: Type checked family instance declarations
 
 \begin{code}
 module FamInstEnv (
 
 \begin{code}
 module FamInstEnv (

-       FamInst(..), famInstTyCon, pprFamInst, pprFamInstHdr, pprFamInsts, 
+       FamInst(..), famInstTyCon, famInstTyVars, 
+       pprFamInst, pprFamInstHdr, pprFamInsts, 

        famInstHead, mkLocalFamInst, mkImportedFamInst,
 
        famInstHead, mkLocalFamInst, mkImportedFamInst,
 

-       FamInstEnv, emptyFamInstEnv, extendFamInstEnv, extendFamInstEnvList, 
+       FamInstEnvs, FamInstEnv, emptyFamInstEnv, 
+       extendFamInstEnv, extendFamInstEnvList, 

        famInstEnvElts, familyInstances,
        famInstEnvElts, familyInstances,

-       lookupFamInstEnv
+
+       lookupFamInstEnv, lookupFamInstEnvUnify

     ) where
 
 #include "HsVersions.h"
 
 import InstEnv
 import Unify
     ) where
 
 #include "HsVersions.h"
 
 import InstEnv
 import Unify

+import TcGadt

 import TcType
 import Type
 import TyCon
 import TcType
 import Type
 import TyCon

@@ -30,7 +34,6 @@ import UniqFM
 import Outputable
 
 import Maybe
 import Outputable
 
 import Maybe

-import Monad

 \end{code}
 
 
 \end{code}
 
 

@@ -43,13 +46,19 @@ import Monad
 \begin{code}
 data FamInst 
   = FamInst { fi_fam   :: Name         -- Family name
 \begin{code}
 data FamInst 
   = FamInst { fi_fam   :: Name         -- Family name

+               -- INVARIANT: fi_fam = case tyConFamInst_maybe fi_tycon of
+               --                         Just (tc, tys) -> tc

 
                -- Used for "rough matching"; same idea as for class instances
            , fi_tcs   :: [Maybe Name]  -- Top of type args
 
                -- Used for "rough matching"; same idea as for class instances
            , fi_tcs   :: [Maybe Name]  -- Top of type args

+               -- INVARIANT: fi_tcs = roughMatchTcs fi_tys

 
                -- Used for "proper matching"; ditto
            , fi_tvs   :: TyVarSet      -- Template tyvars for full match
            , fi_tys   :: [Type]        -- Full arg types
 
                -- Used for "proper matching"; ditto
            , fi_tvs   :: TyVarSet      -- Template tyvars for full match
            , fi_tys   :: [Type]        -- Full arg types

+               -- INVARIANT: fi_tvs = tyConTyVars fi_tycon
+               --            fi_tys = case tyConFamInst_maybe fi_tycon of
+               --                         Just (_, tys) -> tys

 
            , fi_tycon :: TyCon         -- Representation tycon
            }
 
            , fi_tycon :: TyCon         -- Representation tycon
            }

@@ -58,6 +67,8 @@ data FamInst
 --
 famInstTyCon :: FamInst -> TyCon
 famInstTyCon = fi_tycon
 --
 famInstTyCon :: FamInst -> TyCon
 famInstTyCon = fi_tycon

+
+famInstTyVars = fi_tvs

 \end{code}
 
 \begin{code}
 \end{code}
 
 \begin{code}

@@ -71,14 +82,13 @@ instance Outputable FamInst where
 pprFamInst :: FamInst -> SDoc
 pprFamInst famInst
   = hang (pprFamInstHdr famInst)
 pprFamInst :: FamInst -> SDoc
 pprFamInst famInst
   = hang (pprFamInstHdr famInst)

-       2 (ptext SLIT("--") <+> (pprDefnLoc (getSrcLoc famInst)))
+       2 (ptext SLIT("--") <+> (pprDefnLoc (getSrcSpan famInst)))

 
 pprFamInstHdr :: FamInst -> SDoc
 pprFamInstHdr (FamInst {fi_fam = fam, fi_tys = tys, fi_tycon = tycon})
   = pprTyConSort <+> pprHead
   where
 
 pprFamInstHdr :: FamInst -> SDoc
 pprFamInstHdr (FamInst {fi_fam = fam, fi_tys = tys, fi_tycon = tycon})
   = pprTyConSort <+> pprHead
   where

-    pprHead = parenSymOcc (getOccName fam) (ppr fam) <+> 
-             sep (map pprParendType tys)
+    pprHead = pprTypeApp (parenSymOcc (getOccName fam) (ppr fam)) tys

     pprTyConSort | isDataTyCon tycon = ptext SLIT("data instance")
                 | isNewTyCon  tycon = ptext SLIT("newtype instance")
                 | isSynTyCon  tycon = ptext SLIT("type instance")
     pprTyConSort | isDataTyCon tycon = ptext SLIT("data instance")
                 | isNewTyCon  tycon = ptext SLIT("newtype instance")
                 | isSynTyCon  tycon = ptext SLIT("type instance")

@@ -138,6 +148,9 @@ InstEnv maps a family name to the list of known instances for that family.
 \begin{code}
 type FamInstEnv = UniqFM FamilyInstEnv -- Maps a family to its instances
 
 \begin{code}
 type FamInstEnv = UniqFM FamilyInstEnv -- Maps a family to its instances
 

+type FamInstEnvs = (FamInstEnv, FamInstEnv)
+       -- External package inst-env, Home-package inst-env
+

 data FamilyInstEnv
   = FamIE [FamInst]    -- The instances for a particular family, in any order
          Bool          -- True <=> there is an instance of form T a b c
 data FamilyInstEnv
   = FamIE [FamInst]    -- The instances for a particular family, in any order
          Bool          -- True <=> there is an instance of form T a b c

@@ -172,7 +185,7 @@ extendFamInstEnv inst_env ins_item@(FamInst {fi_fam = cls_nm, fi_tcs = mb_tcs})
     add (FamIE items tyvar) _ = FamIE (ins_item:items)
                                      (ins_tyvar || tyvar)
     ins_tyvar = not (any isJust mb_tcs)
     add (FamIE items tyvar) _ = FamIE (ins_item:items)
                                      (ins_tyvar || tyvar)
     ins_tyvar = not (any isJust mb_tcs)

-\end{code}                   
+\end{code}

 
 %************************************************************************
 %*                                                                     *
 
 %************************************************************************
 %*                                                                     *

@@ -185,11 +198,24 @@ Multiple matches are only possible in case of type families (not data
 families), and then, it doesn't matter which match we choose (as the
 instances are guaranteed confluent).
 
 families), and then, it doesn't matter which match we choose (as the
 instances are guaranteed confluent).
 

+We return the matching family instances and the type instance at which it
+matches.  For example, if we lookup 'T [Int]' and have a family instance
+
+  data instance T [a] = ..
+
+desugared to
+
+  data :R42T a = ..
+  coe :Co:R42T a :: T [a] ~ :R42T a
+
+we return the matching instance '(FamInst{.., fi_tycon = :R42T}, Int)'.
+

 \begin{code}
 \begin{code}

-lookupFamInstEnv :: (FamInstEnv        -- External package inst-env
-                   ,FamInstEnv)        -- Home-package inst-env
+type FamInstMatch = (FamInst, [Type])           -- Matching type instance
+
+lookupFamInstEnv :: FamInstEnvs

                 -> TyCon -> [Type]             -- What we are looking for
                 -> TyCon -> [Type]             -- What we are looking for

-                -> [(TvSubst, FamInst)]        -- Successful matches
+                -> [FamInstMatch]              -- Successful matches

 lookupFamInstEnv (pkg_ie, home_ie) fam tys
   = home_matches ++ pkg_matches
   where
 lookupFamInstEnv (pkg_ie, home_ie) fam tys
   = home_matches ++ pkg_matches
   where

@@ -210,6 +236,7 @@ lookupFamInstEnv (pkg_ie, home_ie) fam tys
                     | otherwise                   -> find insts
 
     --------------
                     | otherwise                   -> find insts
 
     --------------

+    find [] = []

     find (item@(FamInst { fi_tcs = mb_tcs, fi_tvs = tpl_tvs, 
                          fi_tys = tpl_tys, fi_tycon = tycon }) : rest)
        -- Fast check for no match, uses the "rough match" fields
     find (item@(FamInst { fi_tcs = mb_tcs, fi_tvs = tpl_tvs, 
                          fi_tys = tpl_tys, fi_tycon = tycon }) : rest)
        -- Fast check for no match, uses the "rough match" fields

@@ -218,9 +245,68 @@ lookupFamInstEnv (pkg_ie, home_ie) fam tys
 
         -- Proper check
       | Just subst <- tcMatchTys tpl_tvs tpl_tys tys
 
         -- Proper check
       | Just subst <- tcMatchTys tpl_tvs tpl_tys tys

-      = (subst, item) : find rest
+      = (item, substTyVars subst (tyConTyVars tycon)) : find rest

 
         -- No match => try next
       | otherwise
       = find rest
 \end{code}
 
         -- No match => try next
       | otherwise
       = find rest
 \end{code}

+
+While @lookupFamInstEnv@ uses a one-way match, the next function
+@lookupFamInstEnvUnify@ uses two-way matching (ie, unification).  This is
+needed to check for overlapping instances.
+
+For class instances, these two variants of lookup are combined into one
+function (cf, @InstEnv@).  We don't do that for family instances as the
+results of matching and unification are used in two different contexts.
+Moreover, matching is the wildly more frequently used operation in the case of
+indexed synonyms and we don't want to slow that down by needless unification.
+
+\begin{code}
+lookupFamInstEnvUnify :: (FamInstEnv, FamInstEnv) -> TyCon -> [Type]
+                     -> [(FamInstMatch)]
+lookupFamInstEnvUnify (pkg_ie, home_ie) fam tys
+  = home_matches ++ pkg_matches
+  where
+    rough_tcs    = roughMatchTcs tys
+    all_tvs      = all isNothing rough_tcs
+    home_matches = lookup home_ie 
+    pkg_matches  = lookup pkg_ie  
+
+    --------------
+    lookup env = case lookupUFM env fam of
+                  Nothing -> []        -- No instances for this class
+                  Just (FamIE insts has_tv_insts)
+                      -- Short cut for common case:
+                      --   The thing we are looking up is of form (C a
+                      --   b c), and the FamIE has no instances of
+                      --   that form, so don't bother to search 
+                    | all_tvs && not has_tv_insts -> []
+                    | otherwise                   -> find insts
+
+    --------------
+    find [] = []
+    find (item@(FamInst { fi_tcs = mb_tcs, fi_tvs = tpl_tvs, 
+                         fi_tys = tpl_tys, fi_tycon = tycon }) : rest)
+       -- Fast check for no match, uses the "rough match" fields
+      | instanceCantMatch rough_tcs mb_tcs
+      = find rest
+
+      | otherwise
+      = ASSERT2( tyVarsOfTypes tys `disjointVarSet` tpl_tvs,
+                (ppr fam <+> ppr tys <+> ppr all_tvs) $$
+                (ppr tycon <+> ppr tpl_tvs <+> ppr tpl_tys)
+               )
+               -- Unification will break badly if the variables overlap
+               -- They shouldn't because we allocate separate uniques for them
+        case tcUnifyTys bind_fn tpl_tys tys of
+           Just subst -> let rep_tys = substTyVars subst (tyConTyVars tycon)
+                          in
+                          (item, rep_tys) : find rest
+           Nothing    -> find rest
+
+-- See explanation at @InstEnv.bind_fn@.
+--
+bind_fn tv | isTcTyVar tv && isExistentialTyVar tv = Skolem
+          | otherwise                             = BindMe
+\end{code}