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 9b49f5c..b8c82f8 100644 (file)
--- a/compiler/types/FamInstEnv.lhs
+++ b/compiler/types/FamInstEnv.lhs
@@ -6,10 +6,12 @@ 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,
 
        lookupFamInstEnv, lookupFamInstEnvUnify
        famInstEnvElts, familyInstances,
 
        lookupFamInstEnv, lookupFamInstEnvUnify

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

-import Monad

 \end{code}
 
 
 \end{code}
 
 

@@ -45,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
            }

@@ -60,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}

@@ -73,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")

@@ -140,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

@@ -174,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}

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

@@ -187,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

@@ -221,7 +245,7 @@ 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
 
         -- No match => try next
       | otherwise

@@ -240,7 +264,7 @@ indexed synonyms and we don't want to slow that down by needless unification.
 
 \begin{code}
 lookupFamInstEnvUnify :: (FamInstEnv, FamInstEnv) -> TyCon -> [Type]
 
 \begin{code}
 lookupFamInstEnvUnify :: (FamInstEnv, FamInstEnv) -> TyCon -> [Type]

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

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

@@ -276,7 +300,9 @@ lookupFamInstEnvUnify (pkg_ie, home_ie) fam 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
                -- 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 -> (subst, item) : find rest
+           Just subst -> let rep_tys = substTyVars subst (tyConTyVars tycon)
+                          in
+                          (item, rep_tys) : find rest

            Nothing    -> find rest
 
 -- See explanation at @InstEnv.bind_fn@.
            Nothing    -> find rest
 
 -- See explanation at @InstEnv.bind_fn@.