Modify PA dictionary computation to work with the class-based scheme

diff --git a/compiler/vectorise/VectMonad.hs b/compiler/vectorise/VectMonad.hs
index 56189f6..10aa2b6 100644 (file)
--- a/compiler/vectorise/VectMonad.hs
+++ b/compiler/vectorise/VectMonad.hs
@@ -13,7 +13,8 @@ module VectMonad (
   LocalEnv(..),
   readLEnv, setLEnv, updLEnv,
 
-  lookupTyCon, extendTyVarPA, deleteTyVarPA,
+  lookupTyCon,
+  lookupTyVarPA, extendTyVarPA, deleteTyVarPA,
 
   lookupInst, lookupFamInst
 ) where
@@ -236,6 +237,9 @@ newTyVar fs k
 lookupTyCon :: TyCon -> VM (Maybe TyCon)
 lookupTyCon tc = readGEnv $ \env -> lookupNameEnv (global_tycons env) (tyConName tc)
 
+lookupTyVarPA :: Var -> VM (Maybe CoreExpr)
+lookupTyVarPA tv = readLEnv $ \env -> lookupVarEnv (local_tyvar_pa env) tv 
+
 extendTyVarPA :: Var -> CoreExpr -> VM ()
 extendTyVarPA tv pa = updLEnv $ \env -> env { local_tyvar_pa = extendVarEnv (local_tyvar_pa env) tv pa }
 
@@ -262,9 +266,7 @@ lookupInst 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)
+          _other         -> noV
        }
   where
     isRight (Left  _) = False

diff --git a/compiler/vectorise/VectUtils.hs b/compiler/vectorise/VectUtils.hs
index 76d625c..acf19d4 100644 (file)
--- a/compiler/vectorise/VectUtils.hs
+++ b/compiler/vectorise/VectUtils.hs
@@ -1,15 +1,18 @@
 module VectUtils (
-  paDictArgType
+  paDictArgType, paDictOfType
 ) where
 
 #include "HsVersions.h"
 
 import VectMonad
 
+import CoreSyn
 import Type
 import TypeRep
 import Var
 
+import Outputable
+
 paDictArgType :: TyVar -> VM (Maybe Type)
 paDictArgType tv = go (TyVarTy tv) (tyVarKind tv)
   where
@@ -30,6 +33,30 @@ paDictArgType tv = go (TyVarTy tv) (tyVarKind tv)
           tc <- builtin paDictTyCon
           return . Just $ TyConApp tc [ty]
 
-
     go ty k = return Nothing
 
+paDictOfType :: Type -> VM CoreExpr
+paDictOfType ty = paDictOfTyApp ty_fn ty_args
+  where
+    (ty_fn, ty_args) = splitAppTys ty
+
+paDictOfTyApp :: Type -> [Type] -> VM CoreExpr
+paDictOfTyApp ty_fn ty_args
+  | Just ty_fn' <- coreView ty_fn = paDictOfTyApp ty_fn' ty_args
+paDictOfTyApp (TyVarTy tv) ty_args
+  = do
+      dfun <- maybeV (lookupTyVarPA tv)
+      paDFunApply dfun ty_args
+paDictOfTyApp (TyConApp tc _) ty_args
+  = do
+      pa_class <- builtin paClass
+      (dfun, ty_args') <- lookupInst pa_class [TyConApp tc ty_args]
+      paDFunApply (Var dfun) ty_args'
+paDictOfTyApp ty ty_args = pprPanic "paDictOfTyApp" (ppr ty)
+
+paDFunApply :: CoreExpr -> [Type] -> VM CoreExpr
+paDFunApply dfun tys
+  = do
+      dicts <- mapM paDictOfType tys
+      return $ mkApps (mkTyApps dfun tys) dicts
+

diff --git a/compiler/vectorise/Vectorise.hs b/compiler/vectorise/Vectorise.hs
index 6dde53a..c845ea3 100644 (file)
--- a/compiler/vectorise/Vectorise.hs
+++ b/compiler/vectorise/Vectorise.hs
@@ -84,9 +84,9 @@ vectBndrsIn vs p
 replicateP :: CoreExpr -> CoreExpr -> VM CoreExpr
 replicateP expr len
   = do
-      pa  <- paOfType ty
-      rep <- builtin replicatePAVar
-      return $ mkApps (Var rep) [Type ty, pa, expr, len]
+      dict <- paDictOfType ty
+      rep  <- builtin replicatePAVar
+      return $ mkApps (Var rep) [Type ty, dict, expr, len]
   where
     ty = exprType expr
 
@@ -165,33 +165,6 @@ vectExpr lc (_, AnnLam bndr body)
                                      Lam pa_var)
 
 -- ----------------------------------------------------------------------------
--- PA dictionaries
-
-paOfTyCon :: TyCon -> VM CoreExpr
--- FIXME: just for now
-paOfTyCon tc = maybeV (readGEnv $ \env -> lookupNameEnv (global_tycon_pa env) (tyConName tc))
-
-paOfType :: Type -> VM CoreExpr
-paOfType ty | Just ty' <- coreView ty = paOfType ty'
-
-paOfType (TyVarTy tv) = maybeV (readLEnv $ \env -> lookupVarEnv (local_tyvar_pa env) tv)
-paOfType (AppTy ty1 ty2)
-  = do
-      e1 <- paOfType ty1
-      e2 <- paOfType ty2
-      return $ mkApps e1 [Type ty2, e2]
-paOfType (TyConApp tc tys)
-  = do
-      e  <- paOfTyCon tc
-      es <- mapM paOfType tys
-      return $ mkApps e [arg | (t,e) <- zip tys es, arg <- [Type t, e]]
-paOfType (FunTy ty1 ty2) = paOfType (TyConApp funTyCon [ty1,ty2])
-paOfType t@(ForAllTy tv ty) = pprPanic "paOfType:" (ppr t)
-paOfType ty = pprPanic "paOfType:" (ppr ty)
-        
-
-
--- ----------------------------------------------------------------------------
 -- Types
 
 vectTyCon :: TyCon -> VM TyCon