From 569b26526403df4d88fe2a6d64c7dade09d003ad Mon Sep 17 00:00:00 2001 From: Richard Eisenberg Date: Fri, 21 Jun 2013 13:54:49 +0100 Subject: Revise implementation of overlapping type family instances. This commit changes the syntax and story around overlapping type family instances. Before, we had "unbranched" instances and "branched" instances. Now, we have closed type families and open ones. The behavior of open families is completely unchanged. In particular, coincident overlap of open type family instances still works, despite emails to the contrary. A closed type family is declared like this: > type family F a where > F Int = Bool > F a = Char The equations are tried in order, from top to bottom, subject to certain constraints, as described in the user manual. It is not allowed to declare an instance of a closed family. --- compiler/vectorise/Vectorise.hs | 3 +-- compiler/vectorise/Vectorise/Env.hs | 2 +- compiler/vectorise/Vectorise/Generic/PAMethods.hs | 4 ++-- compiler/vectorise/Vectorise/Generic/PData.hs | 9 ++++----- compiler/vectorise/Vectorise/Monad/InstEnv.hs | 2 +- compiler/vectorise/Vectorise/Type/Env.hs | 2 +- compiler/vectorise/Vectorise/Utils/Base.hs | 6 +----- compiler/vectorise/Vectorise/Utils/PADict.hs | 2 +- 8 files changed, 12 insertions(+), 18 deletions(-) (limited to 'compiler/vectorise') diff --git a/compiler/vectorise/Vectorise.hs b/compiler/vectorise/Vectorise.hs index b939f4beb6..012ae37039 100644 --- a/compiler/vectorise/Vectorise.hs +++ b/compiler/vectorise/Vectorise.hs @@ -27,7 +27,6 @@ import DynFlags import Outputable import Util ( zipLazy ) import MonadUtils -import FamInstEnv ( toBranchedFamInst ) import Control.Monad @@ -93,7 +92,7 @@ vectModule guts@(ModGuts { mg_tcs = tycons -- and dfuns , mg_binds = Rec tc_binds : (binds_top ++ binds_imp) , mg_fam_inst_env = fam_inst_env - , mg_fam_insts = fam_insts ++ (map toBranchedFamInst new_fam_insts) + , mg_fam_insts = fam_insts ++ new_fam_insts } } diff --git a/compiler/vectorise/Vectorise/Env.hs b/compiler/vectorise/Vectorise/Env.hs index 2d415aab36..3358ceafab 100644 --- a/compiler/vectorise/Vectorise/Env.hs +++ b/compiler/vectorise/Vectorise/Env.hs @@ -174,7 +174,7 @@ extendImportedVarsEnv ps genv -- |Extend the list of type family instances. -- -extendFamEnv :: [FamInst Unbranched] -> GlobalEnv -> GlobalEnv +extendFamEnv :: [FamInst] -> GlobalEnv -> GlobalEnv extendFamEnv new genv = genv { global_fam_inst_env = (g_fam_inst, extendFamInstEnvList l_fam_inst new) } where (g_fam_inst, l_fam_inst) = global_fam_inst_env genv diff --git a/compiler/vectorise/Vectorise/Generic/PAMethods.hs b/compiler/vectorise/Vectorise/Generic/PAMethods.hs index af815c9294..9390696fc7 100644 --- a/compiler/vectorise/Vectorise/Generic/PAMethods.hs +++ b/compiler/vectorise/Vectorise/Generic/PAMethods.hs @@ -32,13 +32,13 @@ import Control.Monad import Outputable -buildPReprTyCon :: TyCon -> TyCon -> SumRepr -> VM (FamInst Unbranched) +buildPReprTyCon :: TyCon -> TyCon -> SumRepr -> VM FamInst buildPReprTyCon orig_tc vect_tc repr = do name <- mkLocalisedName mkPReprTyConOcc (tyConName orig_tc) rhs_ty <- sumReprType repr prepr_tc <- builtin preprTyCon let axiom = mkSingleCoAxiom name tyvars prepr_tc instTys rhs_ty - liftDs $ newFamInst SynFamilyInst False axiom + liftDs $ newFamInst SynFamilyInst axiom where tyvars = tyConTyVars vect_tc instTys = [mkTyConApp vect_tc . mkTyVarTys $ tyConTyVars vect_tc] diff --git a/compiler/vectorise/Vectorise/Generic/PData.hs b/compiler/vectorise/Vectorise/Generic/PData.hs index 893f1559be..6b06996ec8 100644 --- a/compiler/vectorise/Vectorise/Generic/PData.hs +++ b/compiler/vectorise/Vectorise/Generic/PData.hs @@ -14,7 +14,6 @@ import Vectorise.Generic.Description import Vectorise.Utils import Vectorise.Env( GlobalEnv( global_fam_inst_env ) ) -import Coercion( mkSingleCoAxiom ) import BasicTypes import BuildTyCl import DataCon @@ -31,7 +30,7 @@ import Control.Monad -- buildPDataTyCon ------------------------------------------------------------ -- | Build the PData instance tycon for a given type constructor. -buildPDataTyCon :: TyCon -> TyCon -> SumRepr -> VM (FamInst Unbranched) +buildPDataTyCon :: TyCon -> TyCon -> SumRepr -> VM FamInst buildPDataTyCon orig_tc vect_tc repr = fixV $ \fam_inst -> do let repr_tc = dataFamInstRepTyCon fam_inst @@ -42,7 +41,7 @@ buildPDataTyCon orig_tc vect_tc repr where orig_name = tyConName orig_tc -buildDataFamInst :: Name -> TyCon -> TyCon -> AlgTyConRhs -> VM (FamInst Unbranched) +buildDataFamInst :: Name -> TyCon -> TyCon -> AlgTyConRhs -> VM FamInst buildDataFamInst name' fam_tc vect_tc rhs = do { axiom_name <- mkDerivedName mkInstTyCoOcc name' @@ -60,7 +59,7 @@ buildDataFamInst name' fam_tc vect_tc rhs False -- Not promotable False -- not GADT syntax (FamInstTyCon ax fam_tc pat_tys) - ; liftDs $ newFamInst (DataFamilyInst rep_tc) False ax } + ; liftDs $ newFamInst (DataFamilyInst rep_tc) ax } where tyvars = tyConTyVars vect_tc rec_flag = boolToRecFlag (isRecursiveTyCon vect_tc) @@ -92,7 +91,7 @@ buildPDataDataCon orig_name vect_tc repr_tc repr -- buildPDatasTyCon ----------------------------------------------------------- -- | Build the PDatas instance tycon for a given type constructor. -buildPDatasTyCon :: TyCon -> TyCon -> SumRepr -> VM (FamInst Unbranched) +buildPDatasTyCon :: TyCon -> TyCon -> SumRepr -> VM FamInst buildPDatasTyCon orig_tc vect_tc repr = fixV $ \fam_inst -> do let repr_tc = dataFamInstRepTyCon fam_inst diff --git a/compiler/vectorise/Vectorise/Monad/InstEnv.hs b/compiler/vectorise/Vectorise/Monad/InstEnv.hs index ceb62eef80..84b29ceb61 100644 --- a/compiler/vectorise/Vectorise/Monad/InstEnv.hs +++ b/compiler/vectorise/Vectorise/Monad/InstEnv.hs @@ -67,7 +67,7 @@ lookupInst cls tys -- lookupFamInst :: TyCon -> [Type] -> VM FamInstMatch lookupFamInst tycon tys - = ASSERT( isFamilyTyCon tycon ) + = ASSERT( isOpenFamilyTyCon tycon ) do { instEnv <- readGEnv global_fam_inst_env ; case lookupFamInstEnv instEnv tycon tys of [match] -> return match diff --git a/compiler/vectorise/Vectorise/Type/Env.hs b/compiler/vectorise/Vectorise/Type/Env.hs index 0ae0f936b3..66db6185da 100644 --- a/compiler/vectorise/Vectorise/Type/Env.hs +++ b/compiler/vectorise/Vectorise/Type/Env.hs @@ -162,7 +162,7 @@ vectTypeEnv :: [TyCon] -- Type constructors defined in this mo -> [CoreVect] -- All 'VECTORISE [SCALAR] type' declarations in this module -> [CoreVect] -- All 'VECTORISE class' declarations in this module -> VM ( [TyCon] -- old TyCons ++ new TyCons - , [FamInst Unbranched] -- New type family instances. + , [FamInst] -- New type family instances. , [(Var, CoreExpr)]) -- New top level bindings. vectTypeEnv tycons vectTypeDecls vectClassDecls = do { traceVt "** vectTypeEnv" $ ppr tycons diff --git a/compiler/vectorise/Vectorise/Utils/Base.hs b/compiler/vectorise/Vectorise/Utils/Base.hs index d088f45355..0bd54f4408 100644 --- a/compiler/vectorise/Vectorise/Utils/Base.hs +++ b/compiler/vectorise/Vectorise/Utils/Base.hs @@ -39,8 +39,6 @@ import DataCon import MkId import DynFlags import FastString -import Util -import Panic #include "HsVersions.h" @@ -211,10 +209,8 @@ pdataReprTyCon :: Type -> VM (TyCon, [Type]) pdataReprTyCon ty = do { FamInstMatch { fim_instance = famInst - , fim_index = index , fim_tys = tys } <- builtin pdataTyCon >>= (`lookupFamInst` [ty]) - ; ASSERT( index == 0 ) - return (dataFamInstRepTyCon famInst, tys) + ; return (dataFamInstRepTyCon famInst, tys) } -- |Get the representation tycon of the 'PData' data family for a given type constructor. diff --git a/compiler/vectorise/Vectorise/Utils/PADict.hs b/compiler/vectorise/Vectorise/Utils/PADict.hs index 8029dfb466..84a6ff37d9 100644 --- a/compiler/vectorise/Vectorise/Utils/PADict.hs +++ b/compiler/vectorise/Vectorise/Utils/PADict.hs @@ -119,7 +119,7 @@ prDictOfPReprInst :: Type -> VM CoreExpr prDictOfPReprInst ty = do { (FamInstMatch { fim_instance = prepr_fam, fim_tys = prepr_args }) <- preprSynTyCon ty - ; prDictOfPReprInstTyCon ty (famInstAxiom (toUnbranchedFamInst prepr_fam)) prepr_args + ; prDictOfPReprInstTyCon ty (famInstAxiom prepr_fam) prepr_args } -- |Given a type @ty@, its PRepr synonym tycon and its type arguments, -- cgit v1.2.1