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/Exp.hs21
-rw-r--r--compiler/vectorise/Vectorise/Generic/PADict.hs8
-rw-r--r--compiler/vectorise/Vectorise/Generic/PAMethods.hs22
-rw-r--r--compiler/vectorise/Vectorise/Generic/PData.hs31
-rw-r--r--compiler/vectorise/Vectorise/Monad/Base.hs2
-rw-r--r--compiler/vectorise/Vectorise/Monad/InstEnv.hs4
-rw-r--r--compiler/vectorise/Vectorise/Monad/Naming.hs5
-rw-r--r--compiler/vectorise/Vectorise/Type/Env.hs21
-rw-r--r--compiler/vectorise/Vectorise/Type/TyConDecl.hs5
-rw-r--r--compiler/vectorise/Vectorise/Utils/Base.hs21
-rw-r--r--compiler/vectorise/Vectorise/Utils/PADict.hs11
13 files changed, 95 insertions, 61 deletions
diff --git a/compiler/vectorise/Vectorise.hs b/compiler/vectorise/Vectorise.hs
index 012ae37039..b939f4beb6 100644
--- a/compiler/vectorise/Vectorise.hs
+++ b/compiler/vectorise/Vectorise.hs
@@ -27,6 +27,7 @@ import DynFlags
import Outputable
import Util ( zipLazy )
import MonadUtils
+import FamInstEnv ( toBranchedFamInst )
import Control.Monad
@@ -92,7 +93,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 ++ new_fam_insts
+ , mg_fam_insts = fam_insts ++ (map toBranchedFamInst new_fam_insts)
}
}
diff --git a/compiler/vectorise/Vectorise/Env.hs b/compiler/vectorise/Vectorise/Env.hs
index 3358ceafab..2d415aab36 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] -> GlobalEnv -> GlobalEnv
+extendFamEnv :: [FamInst Unbranched] -> 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/Exp.hs b/compiler/vectorise/Vectorise/Exp.hs
index 2fdd223975..34e22f502b 100644
--- a/compiler/vectorise/Vectorise/Exp.hs
+++ b/compiler/vectorise/Vectorise/Exp.hs
@@ -49,6 +49,9 @@ import MonadUtils
import Control.Monad
import Data.Maybe
import Data.List
+import TcRnMonad (goptM)
+import DynFlags
+import Util
-- Main entry point to vectorise expressions -----------------------------------
@@ -735,11 +738,11 @@ unVectDict ty e
; return $ mkCoreConApps dataCon (map Type tys ++ scOps)
}
where
- (tycon, tys, dataCon, methTys) = splitProductType "unVectDict: original type" ty
- cls = case tyConClass_maybe tycon of
- Just cls -> cls
- Nothing -> panic "Vectorise.Exp.unVectDict: no class"
- selIds = classAllSelIds cls
+ (tycon, tys) = splitTyConApp ty
+ Just dataCon = isDataProductTyCon_maybe tycon
+ Just cls = tyConClass_maybe tycon
+ methTys = dataConInstArgTys dataCon tys
+ selIds = classAllSelIds cls
-- Vectorise an 'n'-ary lambda abstraction by building a set of 'n' explicit closures.
--
@@ -798,11 +801,12 @@ vectLam inline loop_breaker expr@((fvs, _vi), AnnLam _ _)
-- in Figure 6 of HtM.
break_loop lc ty (ve, le)
| loop_breaker
- = do { empty <- emptyPD ty
+ = do { dflags <- getDynFlags
+ ; empty <- emptyPD ty
; lty <- mkPDataType ty
; return (ve, mkWildCase (Var lc) intPrimTy lty
[(DEFAULT, [], le),
- (LitAlt (mkMachInt 0), [], empty)])
+ (LitAlt (mkMachInt dflags 0), [], empty)])
}
| otherwise = return (ve, le)
vectLam _ _ _ = panic "Vectorise.Exp.vectLam: not a lambda"
@@ -923,9 +927,10 @@ vectAlgCase tycon _ty_args scrut bndr ty alts
proc_alt arity sel _ lty (DataAlt dc, bndrs, body@((fvs_body, _), _))
= do
+ dflags <- getDynFlags
vect_dc <- maybeV dataConErr (lookupDataCon dc)
let ntag = dataConTagZ vect_dc
- tag = mkDataConTag vect_dc
+ tag = mkDataConTag dflags vect_dc
fvs = fvs_body `delVarSetList` bndrs
sel_tags <- liftM (`App` sel) (builtin (selTags arity))
diff --git a/compiler/vectorise/Vectorise/Generic/PADict.hs b/compiler/vectorise/Vectorise/Generic/PADict.hs
index 96e0dbc225..f70e796daa 100644
--- a/compiler/vectorise/Vectorise/Generic/PADict.hs
+++ b/compiler/vectorise/Vectorise/Generic/PADict.hs
@@ -13,8 +13,9 @@ import BasicTypes
import CoreSyn
import CoreUtils
import CoreUnfold
-import DsMonad
+import Module
import TyCon
+import CoAxiom
import Type
import Id
import Var
@@ -47,7 +48,8 @@ import FastString
--
buildPADict
:: TyCon -- ^ tycon of the type being vectorised.
- -> CoAxiom -- ^ Coercion between the type and
+ -> CoAxiom Unbranched
+ -- ^ Coercion between the type and
-- its vectorised representation.
-> TyCon -- ^ PData instance tycon
-> TyCon -- ^ PDatas instance tycon
@@ -58,7 +60,7 @@ buildPADict vect_tc prepr_ax pdata_tc pdatas_tc repr
= polyAbstract tvs $ \args -> -- The args are the dictionaries we lambda abstract over; and they
-- are put in the envt, so when we need a (PA a) we can find it in
-- the envt; they don't include the silent superclass args yet
- do { mod <- liftDs getModuleDs
+ do { mod <- liftDs getModule
; let dfun_name = mkLocalisedOccName mod mkPADFunOcc vect_tc_name
-- The superclass dictionary is a (silent) argument if the tycon is polymorphic...
diff --git a/compiler/vectorise/Vectorise/Generic/PAMethods.hs b/compiler/vectorise/Vectorise/Generic/PAMethods.hs
index 61c07cd299..af815c9294 100644
--- a/compiler/vectorise/Vectorise/Generic/PAMethods.hs
+++ b/compiler/vectorise/Vectorise/Generic/PAMethods.hs
@@ -18,10 +18,12 @@ import CoreUtils
import FamInstEnv
import MkCore ( mkWildCase )
import TyCon
+import CoAxiom
import Type
import OccName
import Coercion
import MkId
+import FamInst
import DynFlags
import FastString
@@ -30,12 +32,13 @@ import Control.Monad
import Outputable
-buildPReprTyCon :: TyCon -> TyCon -> SumRepr -> VM FamInst
+buildPReprTyCon :: TyCon -> TyCon -> SumRepr -> VM (FamInst Unbranched)
buildPReprTyCon orig_tc vect_tc repr
= do name <- mkLocalisedName mkPReprTyConOcc (tyConName orig_tc)
rhs_ty <- sumReprType repr
prepr_tc <- builtin preprTyCon
- return $ mkSynFamInst name tyvars prepr_tc instTys rhs_ty
+ let axiom = mkSingleCoAxiom name tyvars prepr_tc instTys rhs_ty
+ liftDs $ newFamInst SynFamilyInst False axiom
where
tyvars = tyConTyVars vect_tc
instTys = [mkTyConApp vect_tc . mkTyVarTys $ tyConTyVars vect_tc]
@@ -59,7 +62,8 @@ buildPReprTyCon orig_tc vect_tc repr
--
type PAInstanceBuilder
= TyCon -- ^ Vectorised TyCon
- -> CoAxiom -- ^ Coercion to the representation TyCon
+ -> CoAxiom Unbranched
+ -- ^ Coercion to the representation TyCon
-> TyCon -- ^ 'PData' TyCon
-> TyCon -- ^ 'PDatas' TyCon
-> SumRepr -- ^ Description of generic representation.
@@ -95,7 +99,7 @@ buildToPRepr vect_tc repr_ax _ _ repr
where
ty_args = mkTyVarTys (tyConTyVars vect_tc)
- wrap_repr_inst = wrapTypeFamInstBody repr_ax ty_args
+ wrap_repr_inst = wrapTypeUnbranchedFamInstBody repr_ax ty_args
-- CoreExp to convert the given argument to the generic representation.
-- We start by doing a case branch on the possible data constructors.
@@ -158,7 +162,7 @@ buildFromPRepr vect_tc repr_ax _ _ repr
arg_ty <- mkPReprType res_ty
arg <- newLocalVar (fsLit "x") arg_ty
- result <- from_sum (unwrapTypeFamInstScrut repr_ax ty_args (Var arg))
+ result <- from_sum (unwrapTypeUnbranchedFamInstScrut repr_ax ty_args (Var arg))
repr
return $ Lam arg result
where
@@ -214,7 +218,7 @@ buildToArrPRepr vect_tc repr_co pdata_tc _ r
pdata_co <- mkBuiltinCo pdataTyCon
let co = mkAppCo pdata_co
. mkSymCo
- $ mkAxInstCo repr_co ty_args
+ $ mkUnbranchedAxInstCo repr_co ty_args
scrut = unwrapFamInstScrut pdata_tc ty_args (Var arg)
@@ -278,7 +282,7 @@ buildFromArrPRepr vect_tc repr_co pdata_tc _ r
pdata_co <- mkBuiltinCo pdataTyCon
let co = mkAppCo pdata_co
- $ mkAxInstCo repr_co var_tys
+ $ mkUnbranchedAxInstCo repr_co var_tys
let scrut = mkCast (Var arg) co
@@ -364,7 +368,7 @@ buildToArrPReprs vect_tc repr_co _ pdatas_tc r
pdatas_co <- mkBuiltinCo pdatasTyCon
let co = mkAppCo pdatas_co
. mkSymCo
- $ mkAxInstCo repr_co ty_args
+ $ mkUnbranchedAxInstCo repr_co ty_args
let scrut = unwrapFamInstScrut pdatas_tc ty_args (Var varg)
(vars, result) <- to_sum r
@@ -454,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
- $ mkAxInstCo repr_co var_tys
+ $ mkUnbranchedAxInstCo 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 49997f8502..893f1559be 100644
--- a/compiler/vectorise/Vectorise/Generic/PData.hs
+++ b/compiler/vectorise/Vectorise/Generic/PData.hs
@@ -12,13 +12,17 @@ import Vectorise.Monad
import Vectorise.Builtins
import Vectorise.Generic.Description
import Vectorise.Utils
+import Vectorise.Env( GlobalEnv( global_fam_inst_env ) )
+import Coercion( mkSingleCoAxiom )
import BasicTypes
import BuildTyCl
import DataCon
import TyCon
import Type
+import FamInst
import FamInstEnv
+import TcMType
import Name
import Util
import MonadUtils
@@ -27,7 +31,7 @@ import Control.Monad
-- buildPDataTyCon ------------------------------------------------------------
-- | Build the PData instance tycon for a given type constructor.
-buildPDataTyCon :: TyCon -> TyCon -> SumRepr -> VM FamInst
+buildPDataTyCon :: TyCon -> TyCon -> SumRepr -> VM (FamInst Unbranched)
buildPDataTyCon orig_tc vect_tc repr
= fixV $ \fam_inst ->
do let repr_tc = dataFamInstRepTyCon fam_inst
@@ -38,22 +42,25 @@ buildPDataTyCon orig_tc vect_tc repr
where
orig_name = tyConName orig_tc
-buildDataFamInst :: Name -> TyCon -> TyCon -> AlgTyConRhs -> VM FamInst
+buildDataFamInst :: Name -> TyCon -> TyCon -> AlgTyConRhs -> VM (FamInst Unbranched)
buildDataFamInst name' fam_tc vect_tc rhs
= do { axiom_name <- mkDerivedName mkInstTyCoOcc name'
- ; let fam_inst = mkDataFamInst axiom_name tyvars fam_tc pat_tys rep_tc
- ax = famInstAxiom fam_inst
- pat_tys = [mkTyConApp vect_tc (mkTyVarTys tyvars)]
+ ; (_, tyvars') <- liftDs $ tcInstSkolTyVarsLoc (getSrcSpan name') tyvars
+ ; let ax = mkSingleCoAxiom axiom_name tyvars' fam_tc pat_tys rep_ty
+ tys' = mkTyVarTys tyvars'
+ rep_ty = mkTyConApp rep_tc tys'
+ pat_tys = [mkTyConApp vect_tc tys']
rep_tc = buildAlgTyCon name'
- tyvars
+ tyvars'
Nothing
[] -- no stupid theta
rhs
rec_flag -- FIXME: is this ok?
+ False -- Not promotable
False -- not GADT syntax
(FamInstTyCon ax fam_tc pat_tys)
- ; return fam_inst }
+ ; liftDs $ newFamInst (DataFamilyInst rep_tc) False ax }
where
tyvars = tyConTyVars vect_tc
rec_flag = boolToRecFlag (isRecursiveTyCon vect_tc)
@@ -69,8 +76,8 @@ buildPDataDataCon orig_name vect_tc repr_tc repr
= do let tvs = tyConTyVars vect_tc
dc_name <- mkLocalisedName mkPDataDataConOcc orig_name
comp_tys <- mkSumTys repr_sel_ty mkPDataType repr
-
- liftDs $ buildDataCon dc_name
+ fam_envs <- readGEnv global_fam_inst_env
+ liftDs $ buildDataCon fam_envs dc_name
False -- not infix
(map (const HsNoBang) comp_tys)
[] -- no field labels
@@ -85,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
+buildPDatasTyCon :: TyCon -> TyCon -> SumRepr -> VM (FamInst Unbranched)
buildPDatasTyCon orig_tc vect_tc repr
= fixV $ \fam_inst ->
do let repr_tc = dataFamInstRepTyCon fam_inst
@@ -108,8 +115,8 @@ buildPDatasDataCon orig_name vect_tc repr_tc repr
dc_name <- mkLocalisedName mkPDatasDataConOcc orig_name
comp_tys <- mkSumTys repr_sels_ty mkPDatasType repr
-
- liftDs $ buildDataCon dc_name
+ fam_envs <- readGEnv global_fam_inst_env
+ liftDs $ buildDataCon fam_envs dc_name
False -- not infix
(map (const HsNoBang) comp_tys)
[] -- no field labels
diff --git a/compiler/vectorise/Vectorise/Monad/Base.hs b/compiler/vectorise/Vectorise/Monad/Base.hs
index bb0d045b41..3cb6adb7a6 100644
--- a/compiler/vectorise/Vectorise/Monad/Base.hs
+++ b/compiler/vectorise/Vectorise/Monad/Base.hs
@@ -130,7 +130,7 @@ traceVt herald doc
-- |Dump the given program conditionally.
--
-dumpOptVt :: DynFlag -> String -> SDoc -> VM ()
+dumpOptVt :: DumpFlag -> String -> SDoc -> VM ()
dumpOptVt flag header doc
= do { b <- liftDs $ doptM flag
; if b
diff --git a/compiler/vectorise/Vectorise/Monad/InstEnv.hs b/compiler/vectorise/Vectorise/Monad/InstEnv.hs
index 95546bf503..ceb62eef80 100644
--- a/compiler/vectorise/Vectorise/Monad/InstEnv.hs
+++ b/compiler/vectorise/Vectorise/Monad/InstEnv.hs
@@ -65,12 +65,12 @@ lookupInst cls tys
--
-- which implies that :R42T was declared as 'data instance T [a]'.
--
-lookupFamInst :: TyCon -> [Type] -> VM (FamInst, [Type])
+lookupFamInst :: TyCon -> [Type] -> VM FamInstMatch
lookupFamInst tycon tys
= ASSERT( isFamilyTyCon tycon )
do { instEnv <- readGEnv global_fam_inst_env
; case lookupFamInstEnv instEnv tycon tys of
- [(fam_inst, rep_tys)] -> return ( fam_inst, rep_tys)
+ [match] -> return match
_other ->
do dflags <- getDynFlags
cantVectorise dflags "Vectorise.Monad.InstEnv.lookupFamInst: not found: "
diff --git a/compiler/vectorise/Vectorise/Monad/Naming.hs b/compiler/vectorise/Vectorise/Monad/Naming.hs
index 30b8a0e1e4..def1ffa58c 100644
--- a/compiler/vectorise/Vectorise/Monad/Naming.hs
+++ b/compiler/vectorise/Vectorise/Monad/Naming.hs
@@ -19,6 +19,7 @@ import DsMonad
import TcType
import Type
import Var
+import Module
import Name
import SrcLoc
import MkId
@@ -37,7 +38,7 @@ import Control.Monad
--
mkLocalisedName :: (Maybe String -> OccName -> OccName) -> Name -> VM Name
mkLocalisedName mk_occ name
- = do { mod <- liftDs getModuleDs
+ = do { mod <- liftDs getModule
; u <- liftDs newUnique
; let occ_name = mkLocalisedOccName mod mk_occ name
@@ -86,7 +87,7 @@ cloneVar var = liftM (setIdUnique var) (liftDs newUnique)
--
newExportedVar :: OccName -> Type -> VM Var
newExportedVar occ_name ty
- = do mod <- liftDs getModuleDs
+ = do mod <- liftDs getModule
u <- liftDs newUnique
let name = mkExternalName u mod occ_name noSrcSpan
diff --git a/compiler/vectorise/Vectorise/Type/Env.hs b/compiler/vectorise/Vectorise/Type/Env.hs
index 3f81c1c845..ac4c6846d3 100644
--- a/compiler/vectorise/Vectorise/Type/Env.hs
+++ b/compiler/vectorise/Vectorise/Type/Env.hs
@@ -26,6 +26,7 @@ import CoreUtils
import CoreUnfold
import DataCon
import TyCon
+import CoAxiom
import Type
import FamInstEnv
import Id
@@ -38,6 +39,7 @@ import Unique
import Util
import Outputable
+import DynFlags
import FastString
import MonadUtils
@@ -156,12 +158,12 @@ import Data.List
-- |Vectorise type constructor including class type constructors.
--
-vectTypeEnv :: [TyCon] -- Type constructors defined in this module
- -> [CoreVect] -- All 'VECTORISE [SCALAR] type' declarations in this module
- -> [CoreVect] -- All 'VECTORISE class' declarations in this module
- -> VM ( [TyCon] -- old TyCons ++ new TyCons
- , [FamInst] -- New type family instances.
- , [(Var, CoreExpr)]) -- New top level bindings.
+vectTypeEnv :: [TyCon] -- Type constructors defined in this module
+ -> [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.
+ , [(Var, CoreExpr)]) -- New top level bindings.
vectTypeEnv tycons vectTypeDecls vectClassDecls
= do { traceVt "** vectTypeEnv" $ ppr tycons
@@ -366,7 +368,7 @@ vectTypeEnv tycons vectTypeDecls vectClassDecls
-- Helpers --------------------------------------------------------------------
-buildTyConPADict :: TyCon -> CoAxiom -> TyCon -> TyCon -> VM Var
+buildTyConPADict :: TyCon -> CoAxiom Unbranched -> TyCon -> TyCon -> VM Var
buildTyConPADict vect_tc prepr_ax pdata_tc pdatas_tc
= tyConRepr vect_tc >>= buildPADict vect_tc prepr_ax pdata_tc pdatas_tc
@@ -403,8 +405,9 @@ vectDataConWorkers orig_tc vect_tc arr_tc
rep_tys = map dataConRepArgTys $ tyConDataCons vect_tc
mk_data_con con tys pre post
- = liftM2 (,) (vect_data_con con)
- (lift_data_con tys pre post (mkDataConTag con))
+ = do dflags <- getDynFlags
+ liftM2 (,) (vect_data_con con)
+ (lift_data_con tys pre post (mkDataConTag dflags con))
sel_replicate len tag
| arity > 1 = do
diff --git a/compiler/vectorise/Vectorise/Type/TyConDecl.hs b/compiler/vectorise/Vectorise/Type/TyConDecl.hs
index 05b78246db..588cd39ec0 100644
--- a/compiler/vectorise/Vectorise/Type/TyConDecl.hs
+++ b/compiler/vectorise/Vectorise/Type/TyConDecl.hs
@@ -5,6 +5,7 @@ module Vectorise.Type.TyConDecl (
import Vectorise.Type.Type
import Vectorise.Monad
+import Vectorise.Env( GlobalEnv( global_fam_inst_env ) )
import BuildTyCl
import Class
import Type
@@ -103,6 +104,7 @@ vectTyConDecl tycon name'
[] -- no stupid theta
rhs' -- new constructor defs
rec_flag -- whether recursive
+ False -- Not promotable
gadt_flag -- whether in GADT syntax
NoParentTyCon
}
@@ -169,7 +171,8 @@ vectDataCon dc
; tycon' <- vectTyCon tycon
; arg_tys <- mapM vectType rep_arg_tys
; let ret_ty = mkFamilyTyConApp tycon' (mkTyVarTys univ_tvs)
- ; liftDs $ buildDataCon
+ ; fam_envs <- readGEnv global_fam_inst_env
+ ; liftDs $ buildDataCon fam_envs
name'
(dataConIsInfix dc) -- infix if the original is
(dataConStrictMarks dc) -- strictness as original constructor
diff --git a/compiler/vectorise/Vectorise/Utils/Base.hs b/compiler/vectorise/Vectorise/Utils/Base.hs
index 9ed4e2c60e..d088f45355 100644
--- a/compiler/vectorise/Vectorise/Utils/Base.hs
+++ b/compiler/vectorise/Vectorise/Utils/Base.hs
@@ -37,7 +37,12 @@ import Type
import TyCon
import DataCon
import MkId
+import DynFlags
import FastString
+import Util
+import Panic
+
+#include "HsVersions.h"
-- Simple Types ---------------------------------------------------------------
@@ -58,8 +63,8 @@ newLocalVVar fs vty
-- Constructors ---------------------------------------------------------------
-mkDataConTag :: DataCon -> CoreExpr
-mkDataConTag = mkIntLitInt . dataConTagZ
+mkDataConTag :: DynFlags -> DataCon -> CoreExpr
+mkDataConTag dflags = mkIntLitInt dflags . dataConTagZ
dataConTagZ :: DataCon -> Int
dataConTagZ con = dataConTag con - fIRST_TAG
@@ -205,8 +210,11 @@ unwrapNewTypeBodyOfPDatasWrap e ty
pdataReprTyCon :: Type -> VM (TyCon, [Type])
pdataReprTyCon ty
= do
- { (famInst, tys) <- builtin pdataTyCon >>= (`lookupFamInst` [ty])
- ; return (dataFamInstRepTyCon famInst, tys)
+ { FamInstMatch { fim_instance = famInst
+ , fim_index = index
+ , fim_tys = tys } <- builtin pdataTyCon >>= (`lookupFamInst` [ty])
+ ; ASSERT( index == 0 )
+ return (dataFamInstRepTyCon famInst, tys)
}
-- |Get the representation tycon of the 'PData' data family for a given type constructor.
@@ -230,8 +238,7 @@ pdataReprTyConExact tycon
pdatasReprTyConExact :: TyCon -> VM TyCon
pdatasReprTyConExact tycon
= do { -- look up the representation tycon; if there is a match at all, it will be be exact
- ; -- (i.e.,' _tys' will be distinct type variables)
- ; (ptycon, _tys) <- pdatasReprTyCon (tycon `mkTyConApp` mkTyVarTys (tyConTyVars tycon))
+ ; (FamInstMatch { fim_instance = ptycon }) <- pdatasReprTyCon (tycon `mkTyConApp` mkTyVarTys (tyConTyVars tycon))
; return $ dataFamInstRepTyCon ptycon
}
where
@@ -253,5 +260,5 @@ pdataUnwrapScrut (ve, le)
-- |Get the representation tycon of the 'PRepr' type family for a given type.
--
-preprSynTyCon :: Type -> VM (FamInst, [Type])
+preprSynTyCon :: Type -> VM FamInstMatch
preprSynTyCon ty = builtin preprTyCon >>= (`lookupFamInst` [ty])
diff --git a/compiler/vectorise/Vectorise/Utils/PADict.hs b/compiler/vectorise/Vectorise/Utils/PADict.hs
index 85060c477c..8029dfb466 100644
--- a/compiler/vectorise/Vectorise/Utils/PADict.hs
+++ b/compiler/vectorise/Vectorise/Utils/PADict.hs
@@ -17,6 +17,7 @@ import Coercion
import Type
import TypeRep
import TyCon
+import CoAxiom
import Var
import Outputable
import DynFlags
@@ -117,8 +118,8 @@ paMethod method _ ty
prDictOfPReprInst :: Type -> VM CoreExpr
prDictOfPReprInst ty
= do
- { (prepr_fam, prepr_args) <- preprSynTyCon ty
- ; prDictOfPReprInstTyCon ty (famInstAxiom prepr_fam) prepr_args
+ { (FamInstMatch { fim_instance = prepr_fam, fim_tys = prepr_args }) <- preprSynTyCon ty
+ ; prDictOfPReprInstTyCon ty (famInstAxiom (toUnbranchedFamInst prepr_fam)) prepr_args
}
-- |Given a type @ty@, its PRepr synonym tycon and its type arguments,
@@ -136,15 +137,15 @@ prDictOfPReprInst ty
--
-- Note that @ty@ is only used for error messages
--
-prDictOfPReprInstTyCon :: Type -> CoAxiom -> [Type] -> VM CoreExpr
+prDictOfPReprInstTyCon :: Type -> CoAxiom Unbranched -> [Type] -> VM CoreExpr
prDictOfPReprInstTyCon _ty prepr_ax prepr_args
= do
- let rhs = mkAxInstRHS prepr_ax prepr_args
+ let rhs = mkUnbranchedAxInstRHS prepr_ax prepr_args
dict <- prDictOfReprType' rhs
pr_co <- mkBuiltinCo prTyCon
let co = mkAppCo pr_co
$ mkSymCo
- $ mkAxInstCo prepr_ax prepr_args
+ $ mkUnbranchedAxInstCo 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