PA is now an explicit record instead of a typeclass

diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs
index c09d73d..5bbd994 100644 (file)
--- a/compiler/prelude/PrelNames.lhs
+++ b/compiler/prelude/PrelNames.lhs
@@ -217,7 +217,7 @@ genericTyConNames :: [Name]
 genericTyConNames = [crossTyConName, plusTyConName, genUnitTyConName]
 
 ndpNames :: [Name]
 genericTyConNames = [crossTyConName, plusTyConName, genUnitTyConName]
 
 ndpNames :: [Name]

-ndpNames = [ parrayTyConName, paClassName, closureTyConName
+ndpNames = [ parrayTyConName, paTyConName, closureTyConName

            , mkClosureName, applyClosureName
            , mkClosurePName, applyClosurePName
            , lengthPAName, replicatePAName, emptyPAName ]
            , 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
 
 -- 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
 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
 randomGenClassKey      = mkPreludeClassUnique 32
 
 isStringClassKey       = mkPreludeClassUnique 33

-
-paClassKey              = mkPreludeClassUnique 34

 \end{code}
 
 %************************************************************************
 \end{code}
 
 %************************************************************************

@@ -883,6 +881,7 @@ stringTyConKey                              = mkPreludeTyConUnique 134
 
 parrayTyConKey                          = mkPreludeTyConUnique 135
 closureTyConKey                         = mkPreludeTyConUnique 136
 
 parrayTyConKey                          = mkPreludeTyConUnique 135
 closureTyConKey                         = mkPreludeTyConUnique 136

+paTyConKey                              = mkPreludeTyConUnique 137

 
 
 ---------------- Template Haskell -------------------
 
 
 ---------------- Template Haskell -------------------

diff --git a/compiler/vectorise/VectMonad.hs b/compiler/vectorise/VectMonad.hs
index 6da501f..b7e4b89 100644 (file)
--- a/compiler/vectorise/VectMonad.hs
+++ b/compiler/vectorise/VectMonad.hs
@@ -6,11 +6,11 @@ module VectMonad (
   cloneName, cloneId,
   newExportedVar, newLocalVar, newDummyVar, newTyVar,
   
   cloneName, cloneId,
   newExportedVar, newLocalVar, newDummyVar, newTyVar,
   

-  Builtins(..), paDictTyCon, paDictDataCon,
+  Builtins(..),

   builtin,
 
   GlobalEnv(..),
   builtin,
 
   GlobalEnv(..),

-  setInstEnvs,
+  setFamInstEnv,

   readGEnv, setGEnv, updGEnv,
 
   LocalEnv(..),
   readGEnv, setGEnv, updGEnv,
 
   LocalEnv(..),

@@ -24,14 +24,13 @@ module VectMonad (
   lookupTyConPA, defTyConPA, defTyConRdrPAs,
   lookupTyVarPA, defLocalTyVar, defLocalTyVarWithPA, localTyVars,
 
   lookupTyConPA, defTyConPA, defTyConRdrPAs,
   lookupTyVarPA, defLocalTyVar, defLocalTyVarWithPA, localTyVars,
 

-  lookupInst, lookupFamInst
+  {-lookupInst,-} lookupFamInst

 ) where
 
 #include "HsVersions.h"
 
 import HscTypes
 import CoreSyn
 ) where
 
 #include "HsVersions.h"
 
 import HscTypes
 import CoreSyn

-import Class

 import TyCon
 import DataCon
 import Type
 import TyCon
 import DataCon
 import Type

@@ -64,7 +63,8 @@ data Scope a b = Global a | Local b
 
 data Builtins = Builtins {
                   parrayTyCon      :: TyCon
 
 data Builtins = Builtins {
                   parrayTyCon      :: TyCon

-                , paClass          :: Class
+                , paTyCon          :: TyCon
+                , paDataCon        :: DataCon

                 , closureTyCon     :: TyCon
                 , mkClosureVar     :: Var
                 , applyClosureVar  :: Var
                 , closureTyCon     :: TyCon
                 , mkClosureVar     :: Var
                 , applyClosureVar  :: Var

@@ -76,17 +76,12 @@ data Builtins = Builtins {
                 , liftingContext   :: Var
                 }
 
                 , liftingContext   :: Var
                 }
 

-paDictTyCon :: Builtins -> TyCon
-paDictTyCon = classTyCon . paClass
-
-paDictDataCon :: Builtins -> DataCon
-paDictDataCon = classDataCon . paClass
-

 initBuiltins :: DsM Builtins
 initBuiltins
   = do
       parrayTyCon  <- dsLookupTyCon parrayTyConName
 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
       closureTyCon <- dsLookupTyCon closureTyConName
 
       mkClosureVar     <- dsLookupGlobalId mkClosureName

@@ -102,7 +97,8 @@ initBuiltins
 
       return $ Builtins {
                  parrayTyCon      = parrayTyCon
 
       return $ Builtins {
                  parrayTyCon      = parrayTyCon

-               , paClass          = paClass
+               , paTyCon          = paTyCon
+               , paDataCon        = paDataCon

                , closureTyCon     = closureTyCon
                , mkClosureVar     = mkClosureVar
                , applyClosureVar  = applyClosureVar
                , closureTyCon     = closureTyCon
                , mkClosureVar     = mkClosureVar
                , applyClosureVar  = applyClosureVar

@@ -190,12 +186,11 @@ initGlobalEnv info instEnvs famInstEnvs bi rdr_env
     , global_rdr_env       = 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
 
 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.
 --
 -- 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
 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
   where
     isRight (Left  _) = False
     isRight (Right _) = True

+-}

 
 -- Look up the representation tycon of a family instance.
 --
 
 -- Look up the representation tycon of a family instance.
 --

diff --git a/compiler/vectorise/VectType.hs b/compiler/vectorise/VectType.hs
index 2c38bce..896139f 100644 (file)
--- a/compiler/vectorise/VectType.hs
+++ b/compiler/vectorise/VectType.hs
@@ -1,5 +1,5 @@
 module VectType ( vectTyCon, vectType, vectTypeEnv,
 module VectType ( vectTyCon, vectType, vectTypeEnv,

-                   PAInstance, painstInstance, buildPADict,
+                   PAInstance, buildPADict,

                    vectDataConWorkers )
 where
 
                    vectDataConWorkers )
 where
 

@@ -78,13 +78,13 @@ vectType ty = pprPanic "vectType:" (ppr ty)
 type TyConGroup = ([TyCon], UniqSet TyCon)
 
 data PAInstance = PAInstance {
 type TyConGroup = ([TyCon], UniqSet TyCon)
 
 data PAInstance = PAInstance {

-                    painstInstance  :: Instance
+                    painstDFun      :: Var

                   , painstOrigTyCon :: TyCon
                   , painstVectTyCon :: TyCon
                   , painstArrTyCon  :: TyCon
                   }
 
                   , 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
 vectTypeEnv env
   = do
       cs <- readGEnv $ mk_map . global_tycons

@@ -107,7 +107,7 @@ vectTypeEnv env
                         ++ [ADataCon dc | tc <- all_new_tcs
                                         , dc <- tyConDataCons tc])
 
                         ++ [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
   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
 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 {
 
       return $ PAInstance {

-                 painstInstance  = mkLocalInstance dfun NoOverlap
+                 painstDFun      = dfun

                , painstOrigTyCon = orig_tc
                , painstVectTyCon = vect_tc
                , painstArrTyCon  = arr_tc
                }
                , 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 {
 
 buildPADict :: PAInstance -> VM [(Var, CoreExpr)]
 buildPADict (PAInstance {

-               painstInstance  = inst
+               painstDFun      = dfun

              , painstVectTyCon = vect_tc
              , painstArrTyCon  = arr_tc })
   = polyAbstract (tyConTyVars arr_tc) $ \abstract ->
              , 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
 
       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
       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
   where
     tvs = tyConTyVars arr_tc
     arg_tys = mkTyVarTys tvs

diff --git a/compiler/vectorise/VectUtils.hs b/compiler/vectorise/VectUtils.hs
index b3c110e..27dd330 100644 (file)
--- a/compiler/vectorise/VectUtils.hs
+++ b/compiler/vectorise/VectUtils.hs
@@ -3,7 +3,7 @@ module VectUtils (
   collectAnnValBinders,
   splitClosureTy,
   mkPADictType, mkPArrayType,
   collectAnnValBinders,
   splitClosureTy,
   mkPADictType, mkPArrayType,

-  paDictArgType, paDictOfType,
+  paDictArgType, paDictOfType, paDFunType,

   paMethod, lengthPA, replicatePA, emptyPA, liftPA,
   polyAbstract, polyApply, polyVApply,
   lookupPArrayFamInst,
   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
 mkPADictType :: Type -> VM Type
 mkPADictType ty
   = do

-      tc <- builtin paDictTyCon
+      tc <- builtin paTyCon

       return $ TyConApp tc [ty]
 
 mkPArrayType :: Type -> VM Type
       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
       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)
 
 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
 paDFunApply :: CoreExpr -> [Type] -> VM CoreExpr
 paDFunApply dfun tys
   = do

diff --git a/compiler/vectorise/Vectorise.hs b/compiler/vectorise/Vectorise.hs
index bb5aa0d..39c6a23 100644 (file)
--- a/compiler/vectorise/Vectorise.hs
+++ b/compiler/vectorise/Vectorise.hs
@@ -69,21 +69,18 @@ vectModule :: ModGuts -> VM ModGuts
 vectModule guts
   = do
       defTyConRdrPAs builtin_PAs
 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'
       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_fam_inst_env = fam_inst_env'

-                    , mg_insts        = mg_insts guts ++ insts

                     , mg_fam_insts    = mg_fam_insts guts ++ fam_insts
                     }
 
                     , mg_fam_insts    = mg_fam_insts guts ++ fam_insts
                     }