PA is now an explicit record instead of a typeclass

5 files changed, 51 insertions, 55 deletions

diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs
index c09d73de2f..5bbd9947de 100644
--- a/compiler/prelude/PrelNames.lhs
+++ b/compiler/prelude/PrelNames.lhs
@@ -217,7 +217,7 @@ genericTyConNames :: [Name]
 genericTyConNames = [crossTyConName, plusTyConName, genUnitTyConName]
 
 ndpNames :: [Name]
-ndpNames = [ parrayTyConName, paClassName, closureTyConName
+ndpNames = [ parrayTyConName, paTyConName, closureTyConName
            , mkClosureName, applyClosureName
            , mkClosurePName, applyClosurePName
            , lengthPAName, replicatePAName, emptyPAName ]
@@ -691,7 +691,7 @@ checkDotnetResName  = varQual  dOTNET FSLIT("checkResult")     checkDotnetResNam
 
 -- NDP stuff
 parrayTyConName     = tcQual   nDP_PARRAY FSLIT("PArray") parrayTyConKey
-paClassName         = clsQual  nDP_PARRAY FSLIT("PA")     paClassKey
+paTyConName         = tcQual   nDP_PARRAY FSLIT("PA")     paTyConKey
 lengthPAName        = methName nDP_PARRAY FSLIT("lengthPA")    lengthPAClassOpKey
 replicatePAName     = methName nDP_PARRAY FSLIT("replicatePA") replicatePAClassOpKey
 emptyPAName         = varQual  nDP_PARRAY FSLIT("emptyPA") emptyPAClassOpKey
@@ -769,8 +769,6 @@ randomClassKey		= mkPreludeClassUnique 31
 randomGenClassKey	= mkPreludeClassUnique 32
 
 isStringClassKey	= mkPreludeClassUnique 33
-
-paClassKey              = mkPreludeClassUnique 34
 \end{code}
 
 %************************************************************************
@@ -883,6 +881,7 @@ stringTyConKey				= mkPreludeTyConUnique 134
 
 parrayTyConKey                          = mkPreludeTyConUnique 135
 closureTyConKey                         = mkPreludeTyConUnique 136
+paTyConKey                              = mkPreludeTyConUnique 137
 
 
 ---------------- Template Haskell -------------------
diff --git a/compiler/vectorise/VectMonad.hs b/compiler/vectorise/VectMonad.hs
index 6da501f59d..b7e4b894e2 100644
--- a/compiler/vectorise/VectMonad.hs
+++ b/compiler/vectorise/VectMonad.hs
@@ -6,11 +6,11 @@ module VectMonad (
   cloneName, cloneId,
   newExportedVar, newLocalVar, newDummyVar, newTyVar,
   
-  Builtins(..), paDictTyCon, paDictDataCon,
+  Builtins(..),
   builtin,
 
   GlobalEnv(..),
-  setInstEnvs,
+  setFamInstEnv,
   readGEnv, setGEnv, updGEnv,
 
   LocalEnv(..),
@@ -24,14 +24,13 @@ module VectMonad (
   lookupTyConPA, defTyConPA, defTyConRdrPAs,
   lookupTyVarPA, defLocalTyVar, defLocalTyVarWithPA, localTyVars,
 
-  lookupInst, lookupFamInst
+  {-lookupInst,-} lookupFamInst
 ) where
 
 #include "HsVersions.h"
 
 import HscTypes
 import CoreSyn
-import Class
 import TyCon
 import DataCon
 import Type
@@ -64,7 +63,8 @@ data Scope a b = Global a | Local b
 
 data Builtins = Builtins {
                   parrayTyCon      :: TyCon
-                , paClass          :: Class
+                , paTyCon          :: TyCon
+                , paDataCon        :: DataCon
                 , closureTyCon     :: TyCon
                 , mkClosureVar     :: Var
                 , applyClosureVar  :: Var
@@ -76,17 +76,12 @@ data Builtins = Builtins {
                 , liftingContext   :: Var
                 }
 
-paDictTyCon :: Builtins -> TyCon
-paDictTyCon = classTyCon . paClass
-
-paDictDataCon :: Builtins -> DataCon
-paDictDataCon = classDataCon . paClass
-
 initBuiltins :: DsM Builtins
 initBuiltins
   = do
       parrayTyCon  <- dsLookupTyCon parrayTyConName
-      paClass      <- dsLookupClass paClassName
+      paTyCon      <- dsLookupTyCon paTyConName
+      let paDataCon = case tyConDataCons paTyCon of [dc] -> dc
       closureTyCon <- dsLookupTyCon closureTyConName
 
       mkClosureVar     <- dsLookupGlobalId mkClosureName
@@ -102,7 +97,8 @@ initBuiltins
 
       return $ Builtins {
                  parrayTyCon      = parrayTyCon
-               , paClass          = paClass
+               , paTyCon          = paTyCon
+               , paDataCon        = paDataCon
                , closureTyCon     = closureTyCon
                , mkClosureVar     = mkClosureVar
                , applyClosureVar  = applyClosureVar
@@ -190,12 +186,11 @@ initGlobalEnv info instEnvs famInstEnvs bi rdr_env
     , global_rdr_env       = rdr_env
     }
 
-setInstEnvs :: InstEnv -> FamInstEnv -> GlobalEnv -> GlobalEnv
-setInstEnvs l_inst l_fam_inst genv
-  | (g_inst,     _) <- global_inst_env genv
-  , (g_fam_inst, _) <- global_fam_inst_env genv
-  = genv { global_inst_env     = (g_inst, l_inst)
-         , global_fam_inst_env = (g_fam_inst, l_fam_inst) }
+setFamInstEnv :: FamInstEnv -> GlobalEnv -> GlobalEnv
+setFamInstEnv l_fam_inst genv
+  = genv { global_fam_inst_env = (g_fam_inst, l_fam_inst) }
+  where
+    (g_fam_inst, _) = global_fam_inst_env genv
 
 emptyLocalEnv = LocalEnv {
                    local_vars     = emptyVarEnv
@@ -450,6 +445,7 @@ localTyVars = readLEnv (reverse . local_tyvars)
 -- 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
@@ -466,6 +462,7 @@ lookupInst cls tys
   where
     isRight (Left  _) = False
     isRight (Right _) = True
+-}
 
 -- Look up the representation tycon of a family instance.
 --
diff --git a/compiler/vectorise/VectType.hs b/compiler/vectorise/VectType.hs
index 2c38bcef54..896139fdd5 100644
--- a/compiler/vectorise/VectType.hs
+++ b/compiler/vectorise/VectType.hs
@@ -1,5 +1,5 @@
 module VectType ( vectTyCon, vectType, vectTypeEnv,
-                   PAInstance, painstInstance, buildPADict,
+                   PAInstance, buildPADict,
                    vectDataConWorkers )
 where
 
@@ -78,13 +78,13 @@ vectType ty = pprPanic "vectType:" (ppr ty)
 type TyConGroup = ([TyCon], UniqSet TyCon)
 
 data PAInstance = PAInstance {
-                    painstInstance  :: Instance
+                    painstDFun      :: Var
                   , painstOrigTyCon :: TyCon
                   , painstVectTyCon :: TyCon
                   , painstArrTyCon  :: TyCon
                   }
 
-vectTypeEnv :: TypeEnv -> VM (TypeEnv, [FamInst], [PAInstance])
+vectTypeEnv :: TypeEnv -> VM (TypeEnv, [FamInst])
 vectTypeEnv env
   = do
       cs <- readGEnv $ mk_map . global_tycons
@@ -107,7 +107,7 @@ vectTypeEnv env
                         ++ [ADataCon dc | tc <- all_new_tcs
                                         , dc <- tyConDataCons tc])
 
-      return (new_env, map mkLocalFamInst parr_tcs, pa_insts)
+      return (new_env, map mkLocalFamInst parr_tcs)
   where
     tycons = typeEnvTyCons env
     groups = tyConGroups tycons
@@ -362,26 +362,19 @@ buildPArrayDataCon orig_name vect_tc repr_tc
 buildPAInstance :: TyCon -> TyCon -> TyCon -> VM PAInstance
 buildPAInstance orig_tc vect_tc arr_tc
   = do
-      pa <- builtin paClass
-      let inst_ty = mkForAllTys tvs
-                  . (mkFunTys $ mkPredTys [ClassP pa [ty] | ty <- arg_tys])
-                  $ mkPredTy (ClassP pa [mkTyConApp vect_tc arg_tys])
-
-      dfun <- newExportedVar (mkPADFunOcc $ getOccName vect_tc) inst_ty
+      dfun_ty <- paDFunType vect_tc
+      dfun <- newExportedVar (mkPADFunOcc $ getOccName vect_tc) dfun_ty
 
       return $ PAInstance {
-                 painstInstance  = mkLocalInstance dfun NoOverlap
+                 painstDFun      = dfun
                , painstOrigTyCon = orig_tc
                , painstVectTyCon = vect_tc
                , painstArrTyCon  = arr_tc
                }
-  where
-    tvs = tyConTyVars arr_tc
-    arg_tys = mkTyVarTys tvs
 
 buildPADict :: PAInstance -> VM [(Var, CoreExpr)]
 buildPADict (PAInstance {
-               painstInstance  = inst
+               painstDFun      = dfun
              , painstVectTyCon = vect_tc
              , painstArrTyCon  = arr_tc })
   = polyAbstract (tyConTyVars arr_tc) $ \abstract ->
@@ -390,10 +383,10 @@ buildPADict (PAInstance {
       meth_binds <- mapM (mk_method shape) paMethods
       let meth_exprs = map (Var . fst) meth_binds
 
-      pa_dc <- builtin paDictDataCon
+      pa_dc <- builtin paDataCon
       let dict = mkConApp pa_dc (Type (mkTyConApp vect_tc arg_tys) : meth_exprs)
           body = Let (Rec meth_binds) dict
-      return [(instanceDFunId inst, mkInlineMe $ abstract body)]
+      return [(dfun, mkInlineMe $ abstract body)]
   where
     tvs = tyConTyVars arr_tc
     arg_tys = mkTyVarTys tvs
diff --git a/compiler/vectorise/VectUtils.hs b/compiler/vectorise/VectUtils.hs
index b3c110e980..27dd330036 100644
--- a/compiler/vectorise/VectUtils.hs
+++ b/compiler/vectorise/VectUtils.hs
@@ -3,7 +3,7 @@ module VectUtils (
   collectAnnValBinders,
   splitClosureTy,
   mkPADictType, mkPArrayType,
-  paDictArgType, paDictOfType,
+  paDictArgType, paDictOfType, paDFunType,
   paMethod, lengthPA, replicatePA, emptyPA, liftPA,
   polyAbstract, polyApply, polyVApply,
   lookupPArrayFamInst,
@@ -97,7 +97,7 @@ mkClosureTypes arg_tys res_ty
 mkPADictType :: Type -> VM Type
 mkPADictType ty
   = do
-      tc <- builtin paDictTyCon
+      tc <- builtin paTyCon
       return $ TyConApp tc [ty]
 
 mkPArrayType :: Type -> VM Type
@@ -140,11 +140,21 @@ paDictOfTyApp (TyVarTy tv) ty_args
       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'
+      dfun <- maybeV (lookupTyConPA tc)
+      paDFunApply (Var dfun) ty_args
 paDictOfTyApp ty ty_args = pprPanic "paDictOfTyApp" (ppr ty)
 
+paDFunType :: TyCon -> VM Type
+paDFunType tc
+  = do
+      margs <- mapM paDictArgType tvs
+      res   <- mkPADictType (mkTyConApp tc arg_tys)
+      return . mkForAllTys tvs
+             $ mkFunTys [arg | Just arg <- margs] res
+  where
+    tvs = tyConTyVars tc
+    arg_tys = mkTyVarTys tvs
+
 paDFunApply :: CoreExpr -> [Type] -> VM CoreExpr
 paDFunApply dfun tys
   = do
diff --git a/compiler/vectorise/Vectorise.hs b/compiler/vectorise/Vectorise.hs
index bb5aa0dc91..39c6a23a01 100644
--- a/compiler/vectorise/Vectorise.hs
+++ b/compiler/vectorise/Vectorise.hs
@@ -69,21 +69,18 @@ vectModule :: ModGuts -> VM ModGuts
 vectModule guts
   = do
       defTyConRdrPAs builtin_PAs
-      (types', fam_insts, pa_insts) <- vectTypeEnv (mg_types guts)
+      (types', fam_insts) <- vectTypeEnv (mg_types guts)
       
-      let insts         = map painstInstance pa_insts
-          fam_inst_env' = extendFamInstEnvList (mg_fam_inst_env guts) fam_insts
-          inst_env'     = extendInstEnvList (mg_inst_env guts) insts
-      updGEnv (setInstEnvs inst_env' fam_inst_env')
+      let fam_inst_env' = extendFamInstEnvList (mg_fam_inst_env guts) fam_insts
+      updGEnv (setFamInstEnv fam_inst_env')
      
-      dicts   <- mapM buildPADict pa_insts
-      workers <- mapM vectDataConWorkers pa_insts
+      -- dicts   <- mapM buildPADict pa_insts
+      -- workers <- mapM vectDataConWorkers pa_insts
       binds'  <- mapM vectTopBind (mg_binds guts)
       return $ guts { mg_types        = types'
-                    , mg_binds        = Rec (concat workers ++ concat dicts) : binds'
-                    , mg_inst_env     = inst_env'
+                    , mg_binds        = -- Rec (concat workers ++ concat dicts) :
+                                        binds'
                     , mg_fam_inst_env = fam_inst_env'
-                    , mg_insts        = mg_insts guts ++ insts
                     , mg_fam_insts    = mg_fam_insts guts ++ fam_insts
                     }