summaryrefslogtreecommitdiff
path: root/compiler/vectorise/Vectorise/Generic
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/vectorise/Vectorise/Generic')
-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
3 files changed, 22 insertions, 24 deletions
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
View Lorry Controller Status