-- 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)
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}
_ -> 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
; 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",
; 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)
%************************************************************************
\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..
, 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}
%************************************************************************
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]
--
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
= 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'.
; 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
}
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
; 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
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
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.
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,
--
-- 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
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)
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
-- "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
; 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)
}
--
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)
; 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 $ DataTyCon { data_cons = data_cons'
- , is_enum = is_enum
- }
-vectAlgTyConRhs tc _
- = cantVectorise "Can't vectorise type definition:" (ppr tc)
-
--- |Vectorise a data constructor.
---
--- Vectorises its argument and return types.
+vectAlgTyConRhs tc (AbstractTyCon {})
+ = cantVectorise "Can't vectorise imported abstract type" (ppr tc)
+vectAlgTyConRhs _tc DataFamilyTyCon
+ = return DataFamilyTyCon
+vectAlgTyConRhs _tc (DataTyCon { data_cons = data_cons
+ , is_enum = is_enum
+ })
+ = do { data_cons' <- mapM vectDataCon data_cons
+ ; zipWithM_ defDataCon data_cons data_cons'
+ ; return $ DataTyCon { data_cons = data_cons'
+ , is_enum = is_enum
+ }
+ }
+vectAlgTyConRhs tc (NewTyCon {})
+ = cantVectorise noNewtypeErr (ppr tc)
+ where
+ noNewtypeErr = "Vectorisation of newtypes not supported yet; please use a 'data' declaration"
+
+-- |Vectorise a data constructor by vectorising its argument and return types..
--
vectDataCon :: DataCon -> VM DataCon
vectDataCon dc
- | not . null $ dataConExTyVars dc
- = cantVectorise "Can't vectorise constructor (existentials):" (ppr dc)
-
- | not . null $ dataConEqSpec dc
- = cantVectorise "Can't vectorise constructor (eq spec):" (ppr dc)
-
+ | not . null $ ex_tvs
+ = cantVectorise "Can't vectorise constructor with existential type variables yet" (ppr dc)
+ | not . null $ eq_spec
+ = cantVectorise "Can't vectorise constructor with equality context yet" (ppr dc)
+ | not . null $ dataConFieldLabels dc
+ = cantVectorise "Can't vectorise constructor with labelled fields yet" (ppr dc)
+ | not . null $ theta
+ = cantVectorise "Can't vectorise constructor with constraint context yet" (ppr dc)
| otherwise
- = do
- name' <- mkLocalisedName mkVectDataConOcc name
- tycon' <- vectTyCon tycon
- arg_tys <- mapM vectType rep_arg_tys
-
- liftDs $ buildDataCon
- name'
- False -- not infix
- (map (const HsNoBang) arg_tys) -- strictness annots on args.
- [] -- no labelled fields
- univ_tvs -- universally quantified vars
- [] -- no existential tvs for now
- [] -- no eq spec for now
- [] -- no context
- arg_tys -- argument types
- (mkFamilyTyConApp tycon' (mkTyVarTys univ_tvs)) -- return type
- tycon' -- representation tycon
+ = do { name' <- mkLocalisedName mkVectDataConOcc name
+ ; tycon' <- vectTyCon tycon
+ ; arg_tys <- mapM vectType rep_arg_tys
+ ; let ret_ty = mkFamilyTyConApp tycon' (mkTyVarTys univ_tvs)
+ ; liftDs $ buildDataCon
+ name'
+ (dataConIsInfix dc) -- infix if the original is
+ (dataConStrictMarks dc) -- strictness as original constructor
+ [] -- no labelled fields for now
+ univ_tvs -- universally quantified vars
+ [] -- no existential tvs for now
+ [] -- no equalities for now
+ [] -- no context for now
+ arg_tys -- argument types
+ ret_ty -- return type
+ tycon' -- representation tycon
+ }
where
name = dataConName dc
- univ_tvs = dataConUnivTyVars dc
rep_arg_tys = dataConRepArgTys dc
tycon = dataConTyCon dc
+ (univ_tvs, ex_tvs, eq_spec, theta, _arg_tys, _res_ty) = dataConFullSig dc
dictsPA <- liftM catMaybes $ mapM paDictArgType tyvars
-- pack it all back together.
- traceVt "vect ForAllTy: " $ ppr (abstractType tyvars (dictsPA ++ dictsVect) tyBody'')
return $ abstractType tyvars (dictsPA ++ dictsVect) tyBody''
-- |Add quantified vars and dictionary parameters to the front of a type.
git.haskell.org / ghc.git / commitdiff
