Lookup of class and family instances in vectorisation monad

diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs
index cb861ae..e2b22ee 100644 (file)
--- a/compiler/deSugar/Desugar.lhs
+++ b/compiler/deSugar/Desugar.lhs
@@ -71,6 +71,7 @@ deSugar hsc_env
                            tcg_keep         = keep_var,
                            tcg_rdr_env      = rdr_env,
                            tcg_fix_env      = fix_env,
+                           tcg_inst_env     = inst_env,
                            tcg_fam_inst_env = fam_inst_env,
                            tcg_deprecs      = deprecs,
                            tcg_binds        = binds,
@@ -168,6 +169,7 @@ deSugar hsc_env
                mg_types        = type_env,
                mg_insts        = insts,
                mg_fam_insts    = fam_insts,
+               mg_inst_env     = inst_env,
                mg_fam_inst_env = fam_inst_env,
                mg_rules        = ds_rules,
                mg_binds        = ds_binds,

diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs
index b353caa..f36b205 100644 (file)
--- a/compiler/main/HscTypes.lhs
+++ b/compiler/main/HscTypes.lhs
@@ -521,9 +521,12 @@ data ModGuts
        mg_fix_env   :: !FixityEnv,      -- Fixity env, for things declared in
                                         --   this module 
 
+       mg_inst_env     :: InstEnv,      -- Class instance enviroment fro
+                                        -- *home-package* modules (including
+                                        -- this one); c.f. tcg_inst_env
        mg_fam_inst_env :: FamInstEnv,   -- Type-family instance enviroment
                                         -- for *home-package* modules (including
-                                        -- this one).  c.f. tcg_fam_inst_env
+                                        -- this one); c.f. tcg_fam_inst_env
 
        mg_types     :: !TypeEnv,
        mg_insts     :: ![Instance],     -- Instances 

diff --git a/compiler/vectorise/VectMonad.hs b/compiler/vectorise/VectMonad.hs
index 46204b0..ab77037 100644 (file)
--- a/compiler/vectorise/VectMonad.hs
+++ b/compiler/vectorise/VectMonad.hs
@@ -13,13 +13,16 @@ module VectMonad (
   LocalEnv(..),
   readLEnv, setLEnv, updLEnv,
 
-  lookupTyCon, extendTyVarPA
+  lookupTyCon, extendTyVarPA,
+
+  lookupInst, lookupFamInst
 ) where
 
 #include "HsVersions.h"
 
 import HscTypes
 import CoreSyn
+import Class
 import TyCon
 import Type
 import Var
@@ -31,6 +34,11 @@ import NameEnv
 import DsMonad
 import PrelNames
 
+import InstEnv
+import FamInstEnv
+
+import Panic
+import Outputable
 import FastString
 
 -- ----------------------------------------------------------------------------
@@ -95,6 +103,16 @@ data GlobalEnv = GlobalEnv {
                   -- Mapping from TyCons to their PA dictionaries
                   --
                 , global_tycon_pa :: NameEnv CoreExpr
+
+                -- External package inst-env & home-package inst-env for class
+                -- instances
+                --
+                , global_inst_env :: (InstEnv, InstEnv)
+
+                -- External package inst-env & home-package inst-env for family
+                -- instances
+                --
+                , global_fam_inst_env :: FamInstEnvs
                 }
 
 data LocalEnv = LocalEnv {
@@ -108,13 +126,15 @@ data LocalEnv = LocalEnv {
                }
               
 
-initGlobalEnv :: VectInfo -> GlobalEnv
-initGlobalEnv info
+initGlobalEnv :: VectInfo -> (InstEnv, InstEnv) -> FamInstEnvs -> GlobalEnv
+initGlobalEnv info instEnvs famInstEnvs
   = GlobalEnv {
       global_vars          = mapVarEnv  (Var . snd) $ vectInfoCCVar   info
     , global_exported_vars = emptyVarEnv
     , global_tycons        = mapNameEnv snd $ vectInfoCCTyCon info
     , global_tycon_pa      = emptyNameEnv
+    , global_inst_env      = instEnvs
+    , global_fam_inst_env  = famInstEnvs
     }
 
 emptyLocalEnv = LocalEnv {
@@ -195,6 +215,12 @@ setLEnv lenv = VM $ \_ genv _ -> return (Yes genv lenv ())
 updLEnv :: (LocalEnv -> LocalEnv) -> VM ()
 updLEnv f = VM $ \_ genv lenv -> return (Yes genv (f lenv) ())
 
+getInstEnv :: VM (InstEnv, InstEnv)
+getInstEnv = readGEnv global_inst_env
+
+getFamInstEnv :: VM FamInstEnvs
+getFamInstEnv = readGEnv global_fam_inst_env
+
 newLocalVar :: FastString -> Type -> VM Var
 newLocalVar fs ty
   = do
@@ -213,21 +239,83 @@ lookupTyCon tc = readGEnv $ \env -> lookupNameEnv (global_tycons env) (tyConName
 extendTyVarPA :: Var -> CoreExpr -> VM ()
 extendTyVarPA tv pa = updLEnv $ \env -> env { local_tyvar_pa = extendVarEnv (local_tyvar_pa env) tv pa }
 
+-- Look up the dfun of a class instance.
+--
+-- The match must be unique - ie, match exactly one instance - but the 
+-- type arguments used for matching may be more specific than those of 
+-- the class instance declaration.  The found class instances must not have
+-- any type variables in the instance context that do not appear in the
+-- instances head (i.e., no flexi vars); for details for what this means,
+-- see the docs at InstEnv.lookupInstEnv.
+--
+lookupInst :: Class -> [Type] -> VM (DFunId, [Type])
+lookupInst cls tys
+  = do { instEnv <- getInstEnv
+       ; case lookupInstEnv instEnv cls tys of
+          ([(inst, inst_tys)], _) 
+             | noFlexiVar -> return (instanceDFunId inst, inst_tys')
+             | otherwise  -> pprPanic "VectMonad.lookupInst: flexi var: " 
+                                      (ppr $ mkTyConApp (classTyCon cls) tys)
+             where
+               inst_tys'  = [ty | Right ty <- inst_tys]
+               noFlexiVar = all isRight inst_tys
+          _other                  -> 
+             pprPanic "VectMonad.lookupInst: not found: " 
+                      (ppr $ mkTyConApp (classTyCon cls) tys)
+       }
+  where
+    isRight (Left  _) = False
+    isRight (Right _) = True
+
+-- Look up the representation tycon of a family instance.
+--
+-- The match must be unique - ie, match exactly one instance - but the 
+-- type arguments used for matching may be more specific than those of 
+-- the family instance declaration.
+--
+-- Return the instance tycon and its type instance.  For example, if we have
+--
+--  lookupFamInst 'T' '[Int]' yields (':R42T', 'Int')
+--
+-- then we have a coercion (ie, type instance of family instance coercion)
+--
+--  :Co:R42T Int :: T [Int] ~ :R42T Int
+--
+-- which implies that :R42T was declared as 'data instance T [a]'.
+--
+lookupFamInst :: TyCon -> [Type] -> VM (TyCon, [Type])
+lookupFamInst tycon tys
+  = ASSERT( isOpenTyCon tycon )
+    do { instEnv <- getFamInstEnv
+       ; case lookupFamInstEnv instEnv tycon tys of
+          [(fam_inst, rep_tys)] -> return (famInstTyCon fam_inst, rep_tys)
+          _other                -> 
+             pprPanic "VectMonad.lookupFamInst: not found: " 
+                      (ppr $ mkTyConApp tycon tys)
+       }
+
 initV :: HscEnv -> ModGuts -> VectInfo -> VM a -> IO (Maybe (VectInfo, a))
 initV hsc_env guts info p
   = do
+      eps <- hscEPS hsc_env
+      let famInstEnvs = (eps_fam_inst_env eps, mg_fam_inst_env guts)
+      let instEnvs    = (eps_inst_env     eps, mg_inst_env     guts)
+
       Just r <- initDs hsc_env (mg_module guts)
                                (mg_rdr_env guts)
                                (mg_types guts)
-                               go
+                               (go instEnvs famInstEnvs)
       return r
   where
-    go = do
-           builtins <- initBuiltins
-           r <- runVM p builtins (initGlobalEnv info) emptyLocalEnv
-           case r of
-             Yes genv _ x -> return $ Just (new_info genv, x)
-             No           -> return Nothing
+
+    go instEnvs famInstEnvs = 
+      do
+        builtins <- initBuiltins
+        r <- runVM p builtins (initGlobalEnv info instEnvs famInstEnvs) 
+                   emptyLocalEnv
+        case r of
+          Yes genv _ x -> return $ Just (new_info genv, x)
+          No           -> return Nothing
 
     new_info genv = updVectInfo genv (mg_types guts) info