summaryrefslogtreecommitdiff
path: root/compiler/vectorise
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/vectorise')
-rw-r--r--compiler/vectorise/Vectorise.hs3
-rw-r--r--compiler/vectorise/Vectorise/Env.hs2
-rw-r--r--compiler/vectorise/Vectorise/Generic/PADict.hs24
-rw-r--r--compiler/vectorise/Vectorise/Generic/PAMethods.hs12
-rw-r--r--compiler/vectorise/Vectorise/Generic/PData.hs10
-rw-r--r--compiler/vectorise/Vectorise/Monad/InstEnv.hs2
-rw-r--r--compiler/vectorise/Vectorise/Type/Env.hs4
-rw-r--r--compiler/vectorise/Vectorise/Type/TyConDecl.hs2
-rw-r--r--compiler/vectorise/Vectorise/Utils/Base.hs10
-rw-r--r--compiler/vectorise/Vectorise/Utils/PADict.hs4
10 files changed, 34 insertions, 39 deletions
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/PADict.hs b/compiler/vectorise/Vectorise/Generic/PADict.hs
index f70e796daa..7e70f2dd11 100644
--- a/compiler/vectorise/Vectorise/Generic/PADict.hs
+++ b/compiler/vectorise/Vectorise/Generic/PADict.hs
@@ -68,37 +68,35 @@ buildPADict vect_tc prepr_ax pdata_tc pdatas_tc repr
; pr_cls <- builtin prClass
; return $ mkClassPred pr_cls [r]
}
- ; super_tys <- sequence [mk_super_ty | not (null tvs)]
+ ; super_tys <- sequence [mk_super_ty | not (null tvs)]
; super_args <- mapM (newLocalVar (fsLit "pr")) super_tys
- ; let all_args = super_args ++ args
+ ; let val_args = super_args ++ args
+ all_args = tvs ++ val_args
-- ...it is constant otherwise
; super_consts <- sequence [prDictOfPReprInstTyCon inst_ty prepr_ax [] | null tvs]
-- Get ids for each of the methods in the dictionary, including superclass
; paMethodBuilders <- buildPAScAndMethods
- ; method_ids <- mapM (method all_args dfun_name) paMethodBuilders
+ ; method_ids <- mapM (method val_args dfun_name) paMethodBuilders
-- Expression to build the dictionary.
; pa_dc <- builtin paDataCon
- ; let dict = mkLams (tvs ++ all_args)
- $ mkConApp pa_dc
- $ Type inst_ty
- : map Var super_args ++ super_consts -- the superclass dictionary is either lambda-bound or constant
- ++ map (method_call all_args) method_ids
+ ; let dict = mkLams all_args (mkConApp pa_dc con_args)
+ con_args = Type inst_ty
+ : map Var super_args -- the superclass dictionary is either
+ ++ super_consts -- lambda-bound or constant
+ ++ map (method_call val_args) method_ids
-- Build the type of the dictionary function.
; pa_cls <- builtin paClass
; let dfun_ty = mkForAllTys tvs
- $ mkFunTys (map varType all_args)
+ $ mkFunTys (map varType val_args)
(mkClassPred pa_cls [inst_ty])
-- Set the unfolding for the inliner.
; raw_dfun <- newExportedVar dfun_name dfun_ty
- ; let dfun_unf = mkDFunUnfolding dfun_ty $
- map (const $ DFunLamArg 0) super_args
- ++ map DFunPolyArg super_consts
- ++ map (DFunPolyArg . Var) method_ids
+ ; let dfun_unf = mkDFunUnfolding all_args pa_dc con_args
dfun = raw_dfun `setIdUnfolding` dfun_unf
`setInlinePragma` dfunInlinePragma
diff --git a/compiler/vectorise/Vectorise/Generic/PAMethods.hs b/compiler/vectorise/Vectorise/Generic/PAMethods.hs
index af815c9294..269119c6dd 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]
@@ -218,7 +218,7 @@ buildToArrPRepr vect_tc repr_co pdata_tc _ r
pdata_co <- mkBuiltinCo pdataTyCon
let co = mkAppCo pdata_co
. mkSymCo
- $ mkUnbranchedAxInstCo repr_co ty_args
+ $ mkUnbranchedAxInstCo Nominal repr_co ty_args
scrut = unwrapFamInstScrut pdata_tc ty_args (Var arg)
@@ -282,7 +282,7 @@ buildFromArrPRepr vect_tc repr_co pdata_tc _ r
pdata_co <- mkBuiltinCo pdataTyCon
let co = mkAppCo pdata_co
- $ mkUnbranchedAxInstCo repr_co var_tys
+ $ mkUnbranchedAxInstCo Nominal repr_co var_tys
let scrut = mkCast (Var arg) co
@@ -368,7 +368,7 @@ buildToArrPReprs vect_tc repr_co _ pdatas_tc r
pdatas_co <- mkBuiltinCo pdatasTyCon
let co = mkAppCo pdatas_co
. mkSymCo
- $ mkUnbranchedAxInstCo repr_co ty_args
+ $ mkUnbranchedAxInstCo Nominal repr_co ty_args
let scrut = unwrapFamInstScrut pdatas_tc ty_args (Var varg)
(vars, result) <- to_sum r
@@ -458,7 +458,7 @@ buildFromArrPReprs vect_tc repr_co _ pdatas_tc r
-- Build the coercion between PRepr and the instance type
pdatas_co <- mkBuiltinCo pdatasTyCon
let co = mkAppCo pdatas_co
- $ mkUnbranchedAxInstCo repr_co var_tys
+ $ mkUnbranchedAxInstCo Nominal repr_co var_tys
let scrut = mkCast (Var varg) co
diff --git a/compiler/vectorise/Vectorise/Generic/PData.hs b/compiler/vectorise/Vectorise/Generic/PData.hs
index 893f1559be..37358c9bdf 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'
@@ -53,6 +52,7 @@ buildDataFamInst name' fam_tc vect_tc rhs
pat_tys = [mkTyConApp vect_tc tys']
rep_tc = buildAlgTyCon name'
tyvars'
+ (map (const Nominal) tyvars')
Nothing
[] -- no stupid theta
rhs
@@ -60,7 +60,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 +92,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..34008efbbd 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
@@ -354,7 +354,7 @@ vectTypeEnv tycons vectTypeDecls vectClassDecls
origName = tyConName origTyCon
vectName = tyConName vectTyCon
- mkSyn canonName ty = mkSynTyCon canonName (typeKind ty) [] (SynonymTyCon ty) NoParentTyCon
+ mkSyn canonName ty = mkSynTyCon canonName (typeKind ty) [] [] (SynonymTyCon ty) NoParentTyCon
defDataCons
| isAbstract = return ()
diff --git a/compiler/vectorise/Vectorise/Type/TyConDecl.hs b/compiler/vectorise/Vectorise/Type/TyConDecl.hs
index 588cd39ec0..935ea32c69 100644
--- a/compiler/vectorise/Vectorise/Type/TyConDecl.hs
+++ b/compiler/vectorise/Vectorise/Type/TyConDecl.hs
@@ -62,6 +62,7 @@ vectTyConDecl tycon name'
False -- include unfoldings on dictionary selectors
name' -- new name: "V:Class"
(tyConTyVars tycon) -- keep original type vars
+ (map (const Nominal) (tyConRoles tycon)) -- all role are N for safety
theta' -- superclasses
(snd . classTvsFds $ cls) -- keep the original functional dependencies
[] -- no associated types (for the moment)
@@ -100,6 +101,7 @@ vectTyConDecl tycon name'
; return $ buildAlgTyCon
name' -- new name
(tyConTyVars tycon) -- keep original type vars
+ (map (const Nominal) (tyConRoles tycon)) -- all roles are N for safety
Nothing
[] -- no stupid theta
rhs' -- new constructor defs
diff --git a/compiler/vectorise/Vectorise/Utils/Base.hs b/compiler/vectorise/Vectorise/Utils/Base.hs
index d088f45355..cb7b34e36a 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"
@@ -130,12 +128,12 @@ splitPrimTyCon ty
-- Coercion Construction -----------------------------------------------------
--- |Make a coersion to some builtin type.
+-- |Make a representational coersion to some builtin type.
--
mkBuiltinCo :: (Builtins -> TyCon) -> VM Coercion
mkBuiltinCo get_tc
= do { tc <- builtin get_tc
- ; return $ mkTyConAppCo tc []
+ ; return $ mkTyConAppCo Representational tc []
}
@@ -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..01fbede4bd 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,
@@ -145,7 +145,7 @@ prDictOfPReprInstTyCon _ty prepr_ax prepr_args
pr_co <- mkBuiltinCo prTyCon
let co = mkAppCo pr_co
$ mkSymCo
- $ mkUnbranchedAxInstCo prepr_ax prepr_args
+ $ mkUnbranchedAxInstCo Nominal prepr_ax prepr_args
return $ mkCast dict co
-- |Get the PR dictionary for a type. The argument must be a representation
View Lorry Controller Status