Commit 5ee8081a authored by chak@cse.unsw.edu.au.'s avatar chak@cse.unsw.edu.au.
Browse files

Clean up and complete the vectorisation of type classes

parent b30c6012
......@@ -597,14 +597,14 @@ mkDataCOcc = mk_simple_deriv varName "$c"
-- Vectorisation
mkVectOcc, mkVectTyConOcc, mkVectDataConOcc, mkVectIsoOcc, mkPADFunOcc, mkPReprTyConOcc,
mkPDataTyConOcc, mkPDataDataConOcc :: Maybe String -> OccName -> OccName
mkVectOcc = mk_simple_deriv_with varName "$v_"
mkVectTyConOcc = mk_simple_deriv_with tcName ":V_"
mkVectDataConOcc = mk_simple_deriv_with dataName ":VD_"
mkVectIsoOcc = mk_simple_deriv_with varName "$VI_"
mkPADFunOcc = mk_simple_deriv_with varName "$PA_"
mkPReprTyConOcc = mk_simple_deriv_with tcName ":VR_"
mkPDataTyConOcc = mk_simple_deriv_with tcName ":VP_"
mkPDataDataConOcc = mk_simple_deriv_with dataName ":VPD_"
mkVectOcc = mk_simple_deriv_with varName "$v"
mkVectTyConOcc = mk_simple_deriv_with tcName "V:"
mkVectDataConOcc = mk_simple_deriv_with dataName "VD:"
mkVectIsoOcc = mk_simple_deriv_with varName "$vi"
mkPADFunOcc = mk_simple_deriv_with varName "$pa"
mkPReprTyConOcc = mk_simple_deriv_with tcName "VR:"
mkPDataTyConOcc = mk_simple_deriv_with tcName "VP:"
mkPDataDataConOcc = mk_simple_deriv_with dataName "VPD:"
mk_simple_deriv :: NameSpace -> String -> OccName -> OccName
mk_simple_deriv sp px occ = mk_deriv sp px (occNameString occ)
......
......@@ -339,6 +339,8 @@ vectsFreeVars = foldr (unionVarSet . vectFreeVars) emptyVarSet
vectFreeVars (Vect _ (Just rhs)) = expr_fvs rhs isLocalId emptyVarSet
vectFreeVars (NoVect _) = noFVs
vectFreeVars (VectType _ _ _) = noFVs
vectFreeVars (VectClass _) = noFVs
vectFreeVars (VectInst _ _) = noFVs
-- this function is only concerned with values, not types
\end{code}
......
......@@ -401,7 +401,7 @@ lookupDAPPRdrEnv occ
_ -> pprPanic "Multiple definitions in 'Data.Array.Parallel.Prim':" (ppr occ)
}
-- Find the thing repferred to by an imported name.
-- Find the thing referred to by an imported name.
--
dsImportDecl :: Name -> DsM TyThing
dsImportDecl name
......
......@@ -250,8 +250,7 @@ loadInterface doc_str mod from
; new_eps_fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface)
; new_eps_rules <- tcIfaceRules ignore_prags (mi_rules iface)
; new_eps_anns <- tcIfaceAnnotations (mi_anns iface)
; new_eps_vect_info <- tcIfaceVectInfo mod (mkNameEnv new_eps_decls)
(mi_vect_info iface)
; new_eps_vect_info <- tcIfaceVectInfo mod (mi_vect_info iface)
; let { final_iface = iface {
mi_decls = panic "No mi_decls in PIT",
......
......@@ -273,8 +273,7 @@ typecheckIface iface
; anns <- tcIfaceAnnotations (mi_anns iface)
-- Vectorisation information
; vect_info <- tcIfaceVectInfo (mi_module iface) type_env
(mi_vect_info iface)
; vect_info <- tcIfaceVectInfo (mi_module iface) (mi_vect_info iface)
-- Exports
; exports <- ifaceExportNames (mi_exports iface)
......@@ -711,53 +710,64 @@ tcIfaceAnnTarget (ModuleTarget mod) = do
%************************************************************************
\begin{code}
tcIfaceVectInfo :: Module -> TypeEnv -> IfaceVectInfo -> IfL VectInfo
tcIfaceVectInfo mod typeEnv (IfaceVectInfo
{ ifaceVectInfoVar = vars
, ifaceVectInfoTyCon = tycons
, ifaceVectInfoTyConReuse = tyconsReuse
, ifaceVectInfoScalarVars = scalarVars
, ifaceVectInfoScalarTyCons = scalarTyCons
})
tcIfaceVectInfo :: Module -> IfaceVectInfo -> IfL VectInfo
tcIfaceVectInfo mod (IfaceVectInfo
{ ifaceVectInfoVar = vars
, ifaceVectInfoTyCon = tycons
, ifaceVectInfoTyConReuse = tyconsReuse
, ifaceVectInfoScalarVars = scalarVars
, ifaceVectInfoScalarTyCons = scalarTyCons
})
= do { let scalarTyConsSet = mkNameSet scalarTyCons
; vVars <- mapM vectVarMapping vars
; tyConRes1 <- mapM vectTyConMapping tycons
; tyConRes2 <- mapM (vectTyConReuseMapping scalarTyConsSet) tyconsReuse
; vVars <- mapM vectVarMapping vars
; tyConRes1 <- mapM vectTyConMapping tycons
; tyConRes2 <- mapM (vectTyConReuseMapping scalarTyConsSet) tyconsReuse
; vScalarVars <- mapM vectVar scalarVars
; let (vTyCons, vDataCons) = unzip (tyConRes1 ++ tyConRes2)
; return $ VectInfo
{ vectInfoVar = mkVarEnv vVars
, vectInfoTyCon = mkNameEnv vTyCons
, vectInfoDataCon = mkNameEnv (concat vDataCons)
, vectInfoScalarVars = mkVarSet (map lookupVar scalarVars)
, vectInfoScalarVars = mkVarSet vScalarVars
, vectInfoScalarTyCons = scalarTyConsSet
}
}
where
vectVarMapping name
= do { vName <- lookupOrig mod (mkLocalisedOccName mod mkVectOcc name)
; var <- forkM (ptext (sLit "vect var") <+> ppr name) $
tcIfaceExtId name
; vVar <- forkM (ptext (sLit "vect vVar [mod =") <+>
ppr mod <> ptext (sLit "; nameModule =") <+>
ppr (nameModule name) <> ptext (sLit "]") <+> ppr vName) $
tcIfaceExtId vName
; var <- forkM (ptext (sLit "vect var") <+> ppr name) $
tcIfaceExtId name
; vVar <- forkM (ptext (sLit "vect vVar [mod =") <+>
ppr mod <> ptext (sLit "; nameModule =") <+>
ppr (nameModule name) <> ptext (sLit "]") <+> ppr vName) $
tcIfaceExtId vName
; return (var, (var, vVar))
}
vectVar name
= forkM (ptext (sLit "vect scalar var") <+> ppr name) $
tcIfaceExtId name
vectTyConMapping name
= do { vName <- lookupOrig mod (mkLocalisedOccName mod mkVectTyConOcc name)
-- FIXME: we will need to use tcIfaceTyCon/tcIfaceExtId on some of these (but depends
-- on how we exactly define the 'VECTORISE type' pragma to work)
; let { tycon = lookupTyCon name
; vTycon = lookupTyCon vName
}
; vDataCons <- mapM vectDataConMapping (tyConDataCons tycon)
= do { vName <- lookupOrig mod (mkLocalisedOccName mod mkVectTyConOcc name)
; tycon <- forkM (text ("vect tycon") <+> ppr name) $
tcIfaceTyCon (IfaceTc name)
; vTycon <- forkM (text ("vect vTycon") <+> ppr vName) $
tcIfaceTyCon (IfaceTc vName)
-- we need to handle class type constructors differently due to the manner in which
-- the name for the dictionary data constructor is computed
; vDataCons <- if isClassTyCon tycon
then vectClassDataConMapping vName (tyConSingleDataCon_maybe tycon)
else mapM vectDataConMapping (tyConDataCons tycon)
; return ( (name, (tycon, vTycon)) -- (T, T_v)
, vDataCons -- list of (Ci, Ci_v)
)
}
vectTyConReuseMapping scalarNames name
= do { tycon <- forkM (text ("vect reuse tycon") <+> ppr name) $
tcIfaceTyCon (IfaceTc name) -- somewhat naughty for wired in tycons, but ok
tcIfaceTyCon (IfaceTc name) -- somewhat naughty for wired in tycons, but ok
; if name `elemNameSet` scalarNames
then do
{ return ( (name, (tycon, tycon)) -- scalar type constructors expose no data..
......@@ -772,31 +782,23 @@ tcIfaceVectInfo mod typeEnv (IfaceVectInfo
, vDataCons -- list of (Ci, Ci)
)
}}
vectClassDataConMapping _vTyconName Nothing = panic "tcIfaceVectInfo: vectClassDataConMapping"
vectClassDataConMapping vTyconName (Just datacon)
= do { let name = dataConName datacon
; vName <- lookupOrig mod (mkClassDataConOcc . nameOccName $ vTyconName)
; vDataCon <- forkM (text ("vect class datacon") <+> ppr name) $
tcIfaceDataCon vName
; return [(name, (datacon, vDataCon))]
}
vectDataConMapping datacon
= do { let name = dataConName datacon
; vName <- lookupOrig mod (mkLocalisedOccName mod mkVectDataConOcc name)
; let vDataCon = lookupDataCon vName
; vDataCon <- forkM (text ("vect datacon") <+> ppr name) $
tcIfaceDataCon vName
; return (name, (datacon, vDataCon))
}
--
lookupVar name = case lookupTypeEnv typeEnv name of
Just (AnId var) -> var
Just _ ->
pprPanic "TcIface.tcIfaceVectInfo: not an id" (ppr name)
Nothing ->
pprPanic "TcIface.tcIfaceVectInfo: unknown name of id" (ppr name)
lookupTyCon name = case lookupTypeEnv typeEnv name of
Just (ATyCon tc) -> tc
Just _ ->
pprPanic "TcIface.tcIfaceVectInfo: not a tycon" (ppr name)
Nothing ->
pprPanic "TcIface.tcIfaceVectInfo: unknown name of tycon" (ppr name)
lookupDataCon name = case lookupTypeEnv typeEnv name of
Just (ADataCon dc) -> dc
Just _ ->
pprPanic "TcIface.tcIfaceVectInfo: not a datacon" (ppr name)
Nothing ->
pprPanic "TcIface.tcIfaceVectInfo: unknown name of datacon" (ppr name)
\end{code}
%************************************************************************
......
......@@ -7,13 +7,13 @@ import TcRnTypes ( IfL )
import InstEnv ( Instance )
import FamInstEnv ( FamInst )
import CoreSyn ( CoreRule )
import HscTypes ( TypeEnv, VectInfo, IfaceVectInfo )
import HscTypes ( VectInfo, IfaceVectInfo )
import Module ( Module )
import Annotations ( Annotation )
tcIfaceDecl :: Bool -> IfaceDecl -> IfL TyThing
tcIfaceRules :: Bool -> [IfaceRule] -> IfL [CoreRule]
tcIfaceVectInfo :: Module -> TypeEnv -> IfaceVectInfo -> IfL VectInfo
tcIfaceVectInfo :: Module -> IfaceVectInfo -> IfL VectInfo
tcIfaceInst :: IfaceInst -> IfL Instance
tcIfaceFamInst :: IfaceFamInst -> IfL FamInst
tcIfaceAnnotations :: [IfaceAnnotation] -> IfL [Annotation]
......
......@@ -62,8 +62,6 @@ vectoriseIO hsc_env guts
--
vectModule :: ModGuts -> VM ModGuts
vectModule guts@(ModGuts { mg_tcs = tycons
, mg_clss = classes
, mg_insts = insts
, mg_binds = binds
, mg_fam_insts = fam_insts
, mg_vect_decls = vect_decls
......@@ -71,18 +69,29 @@ vectModule guts@(ModGuts { mg_tcs = tycons
= do { dumpOptVt Opt_D_dump_vt_trace "Before vectorisation" $
pprCoreBindings binds
-- Pick out all 'VECTORISE type' and 'VECTORISE class' pragmas
; let ty_vect_decls = [vd | vd@(VectType _ _ _) <- vect_decls]
cls_vect_decls = [vd | vd@(VectClass _) <- vect_decls]
-- Vectorise the type environment. This will add vectorised
-- type constructors, their representaions, and the
-- conrresponding data constructors. Moreover, we produce
-- bindings for dfuns and family instances of the classes
-- and type families used in the DPH library to represent
-- array types.
; (new_tycons, new_fam_insts, tc_binds) <- vectTypeEnv tycons [vd
| vd@(VectType _ _ _) <- vect_decls]
; (new_tycons, new_fam_insts, tc_binds) <- vectTypeEnv tycons ty_vect_decls cls_vect_decls
{- TODO:
instance Num Int where
(+) = primAdd
{-# VECTORISE SCALAR instance Num Int #-}
; let new_classes = [] -- !!!FIXME
new_insts = []
-- !!!we need to compute an extended 'mg_inst_env' as well!!!
==> $dNumInt :: Num Int; $dNumInt = Num primAdd
=>> $v$dNumInt :: $vNum Int
$v$dNumInt = $vNum (closure1 (scalar_zipWith primAdd) (scalar_zipWith primAdd))
$dNumInt -v> $v$dNumInt
-}
-- Family instance environment for /all/ home-package modules including those instances
-- generated by 'vectTypeEnv'.
......@@ -93,8 +102,8 @@ vectModule guts@(ModGuts { mg_tcs = tycons
; binds_imp <- mapM vectImpBind [imp_id | Vect imp_id _ <- vect_decls, isGlobalId imp_id]
; return $ guts { mg_tcs = tycons ++ new_tycons
, mg_clss = classes ++ new_classes
, mg_insts = insts ++ new_insts
-- we produce no new classes or instances, only new class type constructors
-- 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
......
......@@ -198,7 +198,8 @@ modVectInfo env mg_ids mg_tyCons vectDecls info
}
where
vectIds = [id | Vect id _ <- vectDecls]
vectTypeTyCons = [tycon | VectType _ tycon _ <- vectDecls]
vectTypeTyCons = [tycon | VectType _ tycon _ <- vectDecls] ++
[tycon | VectClass tycon <- vectDecls]
vectDataCons = concatMap tyConDataCons vectTypeTyCons
ids = mg_ids ++ vectIds
tyCons = mg_tyCons ++ vectTypeTyCons
......
......@@ -85,8 +85,8 @@ initV hsc_env guts info thing_inside
; eps <- liftIO $ hscEPS hsc_env
; let famInstEnvs = (eps_fam_inst_env eps, mg_fam_inst_env guts)
instEnvs = (eps_inst_env eps, mg_inst_env guts)
builtin_pas = initClassDicts instEnvs (paClass builtins) -- grab all available 'PA' and..
builtin_prs = initClassDicts instEnvs (prClass builtins) -- ..'PR' class instances
builtin_pas = initClassDicts instEnvs (paClass builtins) -- grab all 'PA' and..
builtin_prs = initClassDicts instEnvs (prClass builtins) -- ..'PR' class instances
-- construct the initial global environment
; let thing_inside' = traceVt "VectDecls" (ppr (mg_vect_decls guts)) >> thing_inside
......@@ -110,9 +110,9 @@ initV hsc_env guts info thing_inside
new_info genv = modVectInfo genv ids (mg_tcs guts) (mg_vect_decls guts) info
-- For a given DPH class, produce a mapping from type constructor (in head position) to the instance
-- dfun for that type constructor and class. (DPH class instances cannot overlap in head
-- constructors.)
-- For a given DPH class, produce a mapping from type constructor (in head position) to the
-- instance dfun for that type constructor and class. (DPH class instances cannot overlap in
-- head constructors.)
--
initClassDicts :: (InstEnv, InstEnv) -> Class -> [(Name, Var)]
initClassDicts insts cls = map find $ classInstances insts cls
......
......@@ -26,7 +26,7 @@ import Type
import Digraph
-- |From a list of type constructors, extract those thatcan be vectorised, returning them in two
-- |From a list of type constructors, extract those that can be vectorised, returning them in two
-- sets, where the first result list /must be/ vectorised and the second result list /need not be/
-- vectroised.
......@@ -55,7 +55,11 @@ classifyTyCons convStatus tcs = classify [] [] convStatus (tyConGroups tcs)
can_convert = isNullUFM (refs `minusUFM` cs) && all convertable tcs
must_convert = foldUFM (||) False (intersectUFM_C const cs refs)
convertable tc = isDataTyCon tc && all isVanillaDataCon (tyConDataCons tc)
-- We currently admit Haskell 2011-style data and newtype declarations as well as type
-- constructors representing classes.
convertable tc
= (isDataTyCon tc || isNewTyCon tc) && all isVanillaDataCon (tyConDataCons tc)
|| isClassTyCon tc
-- Used to group type constructors into mutually dependent groups.
--
......
{-# OPTIONS_GHC -XNoMonoLocalBinds #-}
-- Vectorise a modules type environment, the structure containing all type things defined in a
-- module.
-- Vectorise a modules type and class declarations.
--
-- This extends the type environment with vectorised variants of data types and produces value
-- bindings for worker functions and the like.
-- This produces new type constructors and family instances top be included in the module toplevel
-- as well as bindings for worker functions, dfuns, and the like.
module Vectorise.Type.Env (
vectTypeEnv,
......@@ -91,19 +88,47 @@ import Data.List
--
-- Type constructors declared with {-# VECTORISE type T = T' #-} are treated in this manner.
--
-- In addition, we have also got a single pragma form for type classes: {-# VECTORISE class C #-}. It
-- implies that the class type constructor may be used in vectorised code together with its data
-- In addition, we have also got a single pragma form for type classes: {-# VECTORISE class C #-}.
-- It implies that the class type constructor may be used in vectorised code together with its data
-- constructor. We generally produce a vectorised version of the data type and data constructor.
-- We do not generate 'PData' and 'PRepr' instances for class type constructors.
-- We do not generate 'PData' and 'PRepr' instances for class type constructors. This pragma is the
-- default for all type classes declared in this module, but the pragma can also be used explitly on
-- imported classes.
-- Note [Vectorising classes]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~
--
-- We vectorise classes essentially by just vectorising their desugared Core representation, but we
-- do generate a 'Class' structure along the way (see 'Vectorise.Type.TyConDecl.vectTyConDecl').
--
-- Here is an example illustrating the mapping — assume
--
-- class Num a where
-- (+) :: a -> a -> a
--
-- It desugars to
--
-- data Num a = Num { (+) :: a -> a -> a }
--
-- which we vectorise to
--
-- data $vNum a = $vNum { ($v+) :: PArray a :-> PArray a :-> PArray a }
--
-- while adding the following entries to the vectorisation map:
--
-- tycon : Num --> $vNum
-- datacon: Num --> $vNum
-- var : (+) --> ($v+)
-- |Vectorise a type environment.
-- |Vectorise type constructor including class type constructors.
--
vectTypeEnv :: [TyCon] -- TyCons defined in this module
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 tycons vectTypeDecls
vectTypeEnv tycons vectTypeDecls vectClassDecls
= do { traceVt "** vectTypeEnv" $ ppr tycons
-- Build a map containing all vectorised type constructor. If they are scalar, they are
......@@ -118,7 +143,8 @@ vectTypeEnv tycons vectTypeDecls
localScalarTyCons = [tycon | VectType True tycon Nothing <- vectTypeDecls]
-- {-# VECTORISE type T -#} (ONLY the imported tycons)
impVectTyCons = [tycon | VectType False tycon Nothing <- vectTypeDecls]
impVectTyCons = ( [tycon | VectType False tycon Nothing <- vectTypeDecls]
++ [tycon | VectClass tycon <- vectClassDecls])
\\ tycons
-- {-# VECTORISE type T = ty -#} (imported and local tycons)
......@@ -141,7 +167,9 @@ vectTypeEnv tycons vectTypeDecls
orig_tcs = keep_tcs ++ conv_tcs
; traceVt " VECT SCALAR : " $ ppr localScalarTyCons
; traceVt " VECT [class] : " $ ppr impVectTyCons
; traceVt " VECT with rhs : " $ ppr (map fst vectTyConsWithRHS)
; traceVt " -- after classification (local and VECT [class] tycons) --" empty
; traceVt " reuse : " $ ppr keep_tcs
; traceVt " convert : " $ ppr conv_tcs
......@@ -164,7 +192,8 @@ vectTypeEnv tycons vectTypeDecls
-- "Note [Pragmas to vectorise tycons]".
; mapM_ (uncurry defTyConDataCons) vectTyConsWithRHS
-- Vectorise all the data type declarations that we can and must vectorise.
-- Vectorise all the data type declarations that we can and must vectorise (enter the
-- type and data constructors into the vectorisation map on-the-fly.)
; new_tcs <- vectTyConDecls conv_tcs
-- We don't need new representation types for dictionary constructors. The constructors
......@@ -198,8 +227,8 @@ vectTypeEnv tycons vectTypeDecls
; return (dfuns, binds)
}
-- Return the vectorised variants of type constructors as well as the generated instance type
-- constructors, family instances, and dfun bindings.
-- Return the vectorised variants of type constructors as well as the generated instance
-- type constructors, family instances, and dfun bindings.
; return (new_tcs ++ inst_tcs, fam_insts, binds)
}
......
......@@ -21,81 +21,92 @@ import Control.Monad
--
vectTyConDecls :: [TyCon] -> VM [TyCon]
vectTyConDecls tcs = fixV $ \tcs' ->
do
mapM_ (uncurry defTyCon) (zipLazy tcs tcs')
mapM vectTyConDecl tcs
do { mapM_ (uncurry defTyCon) (zipLazy tcs tcs')
; mapM vectTyConDecl tcs
}
-- |Vectorise a single type constructor.
--
vectTyConDecl :: TyCon -> VM TyCon
vectTyConDecl tycon
-- a type class constructor.
-- TODO: check for no stupid theta, fds, assoc types.
| isClassTyCon tycon
, Just cls <- tyConClass_maybe tycon
= do -- make the name of the vectorised class tycon.
name' <- mkLocalisedName mkVectTyConOcc (tyConName tycon)
-- vectorise right of definition.
rhs' <- vectAlgTyConRhs tycon (algTyConRhs tycon)
-- vectorise method selectors.
-- This also adds a mapping between the original and vectorised method selector
-- to the state.
methods' <- mapM vectMethod
$ [(id, defMethSpecOfDefMeth meth)
| (id, meth) <- classOpItems cls]
-- keep the original recursiveness flag.
let rec_flag = boolToRecFlag (isRecursiveTyCon tycon)
-- Calling buildclass here attaches new quantifiers and dictionaries to the method types.
cls' <- liftDs
$ buildClass
False -- include unfoldings on dictionary selectors.
name' -- new name V_T:Class
(tyConTyVars tycon) -- keep original type vars
[] -- no stupid theta
[] -- no functional dependencies
[] -- no associated types
methods' -- method info
rec_flag -- whether recursive
let tycon' = mkClassTyCon name'
(tyConKind tycon)
(tyConTyVars tycon)
rhs'
cls'
rec_flag
return $ tycon'
-- Type constructor representing a type class
| Just cls <- tyConClass_maybe tycon
= do { unless (null $ classATs cls) $
cantVectorise "Associated types are not yet supported" (ppr cls)
-- make the name of the vectorised class tycon: "Class" --> "V:Class"
; name' <- mkLocalisedName mkVectTyConOcc (tyConName tycon)
-- vectorise superclass constraint (types)
; theta' <- mapM vectType (classSCTheta cls)
-- vectorise method selectors and add them to the vectorisation map
; methods' <- sequence [ vectMethod id meth | (id, meth) <- classOpItems cls]
-- keep the original recursiveness flag
; let rec_flag = boolToRecFlag (isRecursiveTyCon tycon)
-- construct the vectorised class (this also creates the class type constructors and its
-- data constructor)
--
-- NB: 'buildClass' attaches new quantifiers and dictionaries to the method types
; cls' <- liftDs $
buildClass
False -- include unfoldings on dictionary selectors
name' -- new name: "V:Class"
(tyConTyVars tycon) -- keep original type vars
theta' -- superclasses
(snd . classTvsFds $ cls) -- keep the original functional dependencies
[] -- no associated types (for the moment)
methods' -- method info
rec_flag -- whether recursive
-- the original dictionary constructor must map to the vectorised one
; let tycon' = classTyCon cls'
Just datacon = tyConSingleDataCon_maybe tycon
Just datacon' = tyConSingleDataCon_maybe tycon'
; defDataCon datacon datacon'
-- return the type constructor of the vectorised class
; return tycon'
}
-- a regular algebraic type constructor.
-- TODO: check for stupid theta, generaics, GADTS etc
-- Regular algebraic type constructor — for now, Haskell 2011-style only
| isAlgTyCon tycon
= do name' <- mkLocalisedName mkVectTyConOcc (tyConName tycon)
rhs' <- vectAlgTyConRhs tycon (algTyConRhs tycon)
let rec_flag = boolToRecFlag (isRecursiveTyCon tycon)
liftDs $ buildAlgTyCon
name' -- new name
(tyConTyVars tycon) -- keep original type vars.
[] -- no stupid theta.
rhs' -- new constructor defs.
rec_flag -- FIXME: is this ok?
False -- not GADT syntax
NoParentTyCon
Nothing -- not a family instance
-- some other crazy thing that we don't handle.
| otherwise
= cantVectorise "Can't vectorise type constructor: " (ppr tycon)
-- | Vectorise a class method.
vectMethod :: (Id, DefMethSpec) -> VM (Name, DefMethSpec, Type)
vectMethod (id, defMeth)
= do { unless (all isVanillaDataCon (tyConDataCons tycon)) $
cantVectorise "Currently only Haskell 2011 datatypes are supported" (ppr tycon)
-- make the name of the vectorised class tycon
; name' <- mkLocalisedName mkVectTyConOcc (tyConName tycon)
-- vectorise the data constructor of the class tycon
; rhs' <- vectAlgTyConRhs tycon (algTyConRhs tycon)
-- keep the original recursiveness and GADT flags
; let rec_flag = boolToRecFlag (isRecursiveTyCon tycon)
gadt_flag = isGadtSyntaxTyCon tycon
-- build the vectorised type constructor
; liftDs $ buildAlgTyCon
name' -- new name
(tyConTyVars tycon) -- keep original type vars
[] -- no stupid theta
rhs' -- new constructor defs
rec_flag -- whether recursive
gadt_flag -- whether in GADT syntax
NoParentTyCon
Nothing -- not a family instance
}
-- some other crazy thing that we don't handle
| otherwise
= cantVectorise "Can't vectorise exotic type constructor" (ppr tycon)
-- |Vectorise a class method.
--
vectMethod :: Id -> DefMeth -> VM (Name, DefMethSpec, Type)
vectMethod id defMeth
= do { -- Vectorise the method type.
; typ' <- vectType (varType id)
......@@ -110,56 +121,62 @@ vectMethod (id, defMeth)
; let (_tyvars, tyBody) = splitForAllTys typ'
; let (_dict, tyRest) = splitFunTy tyBody
; return (Var.varName id', defMeth, tyRest)
; return (Var.varName id', defMethSpecOfDefMeth defMeth, tyRest)
}
-- |Vectorise the RHS of an algebraic type.
--
vectAlgTyConRhs :: TyCon -> AlgTyConRhs -> VM AlgTyConRhs
vectAlgTyConRhs _ (DataTyCon { data_cons = data_cons
, is_enum = is_enum
})
= do
data_cons' <- mapM vectDataCon data_cons
zipWithM_ defDataCon data_cons data_cons'
return <