Skip to content

GitLab

Commit fb12748e authored by benl@ouroborus.net's avatar benl@ouroborus.net
Browse files

Break out vectorisation of TyConDecls into own module

parent 099ead5c
Hide whitespace changes
Inline Side-by-side
compiler/ghc.cabal.in
View file @ fb12748e
......@@ -460,6 +460,7 @@ Library
Vectorise.Env
Vectorise.Vect
Vectorise.Type.Type
Vectorise.Type.TyConDecl
Vectorise.Builtins.Base
Vectorise.Builtins.Initialise
Vectorise.Builtins.Modules
......
compiler/vectorise/VectType.hs
View file @ fb12748e
......@@ -12,6 +12,7 @@ import Vectorise.Vect
import Vectorise.Monad
import Vectorise.Builtins
import Vectorise.Type.Type
import Vectorise.Type.TyConDecl
import HscTypes ( TypeEnv, extendTypeEnvList, typeEnvTyCons )
import BasicTypes
......@@ -22,7 +23,6 @@ import MkCore ( mkWildCase )
import BuildTyCl
import DataCon
import TyCon
import Class
import Type
import TypeRep
import Coercion
......@@ -73,15 +73,11 @@ vectTypeEnv env
let (conv_tcs, keep_tcs) = classifyTyCons cs groups
keep_dcs = concatMap tyConDataCons keep_tcs
dtrace (text "conv_tcs = " <> ppr conv_tcs) $ return ()
zipWithM_ defTyCon keep_tcs keep_tcs
zipWithM_ defDataCon keep_dcs keep_dcs
new_tcs <- vectTyConDecls conv_tcs
dtrace (text "new_tcs = " <> ppr new_tcs) $ return ()
let orig_tcs = keep_tcs ++ conv_tcs
-- We don't need to make new representation types for dictionary
......@@ -91,11 +87,6 @@ vectTypeEnv env
let vect_tcs = filter (not . isClassTyCon)
$ keep_tcs ++ new_tcs
dtrace (text "vect_tcs = " <> ppr vect_tcs) $ return ()
mapM_ dumpTycon $ new_tcs
(_, binds, inst_tcs) <- fixV $ \ ~(dfuns', _, _) ->
do
defTyConPAs (zipLazy vect_tcs dfuns')
......@@ -129,162 +120,6 @@ vectTypeEnv env
mk_map env = listToUFM_Directly [(u, getUnique n /= u) | (u,n) <- nameEnvUniqueElts env]
-- | Vectorise some (possibly recursively defined) type constructors.
vectTyConDecls :: [TyCon] -> VM [TyCon]
vectTyConDecls tcs = fixV $ \tcs' ->
do
mapM_ (uncurry defTyCon) (zipLazy tcs tcs')
mapM vectTyConDecl tcs
dumpTycon :: TyCon -> VM ()
dumpTycon tycon
| Just cls <- tyConClass_maybe tycon
= dtrace (vcat [ ppr tycon
, ppr [(m, varType m) | m <- classMethods cls ]])
$ return ()
| otherwise
= return ()
-- | Vectorise a single type construcrtor.
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' <- cloneName 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'
-- a regular algebraic type constructor.
-- TODO: check for stupid theta, generaics, GADTS etc
| isAlgTyCon tycon
= do name' <- cloneName 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 -- FIXME: no generics
False -- not GADT syntax
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
-- Vectorise the method type.
typ' <- vectType (varType id)
-- Create a name for the vectorised method.
id' <- cloneId mkVectOcc id typ'
defGlobalVar id id'
-- When we call buildClass in vectTyConDecl, it adds foralls and dictionaries
-- to the types of each method. However, the types we get back from vectType
-- above already already have these, so we need to chop them off here otherwise
-- we'll get two copies in the final version.
let (_tyvars, tyBody) = splitForAllTys typ'
let (_dict, tyRest) = splitFunTy tyBody
return (Var.varName id', 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.
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)
| otherwise
= do
name' <- cloneName 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
where
name = dataConName dc
univ_tvs = dataConUnivTyVars dc
rep_arg_tys = dataConRepArgTys dc
tycon = dataConTyCon dc
mk_fam_inst :: TyCon -> TyCon -> (TyCon, [Type])
mk_fam_inst fam_tc arg_tc
= (fam_tc, [mkTyConApp arg_tc . mkTyVarTys $ tyConTyVars arg_tc])
......
compiler/vectorise/Vectorise/Type/TyConDecl.hs 0 → 100644
View file @ fb12748e
module Vectorise.Type.TyConDecl
(vectTyConDecls)
where
import Vectorise.Type.Type
import Vectorise.Monad
import BuildTyCl
import Class
import Type
import TyCon
import DataCon
import BasicTypes
import Var
import Name
import Outputable
import Util
import Control.Monad
-- | Vectorise some (possibly recursively defined) type constructors.
vectTyConDecls :: [TyCon] -> VM [TyCon]
vectTyConDecls tcs = fixV $ \tcs' ->
do
mapM_ (uncurry defTyCon) (zipLazy tcs tcs')
mapM vectTyConDecl tcs
-- | Vectorise a single type construcrtor.
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' <- cloneName 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'
-- a regular algebraic type constructor.
-- TODO: check for stupid theta, generaics, GADTS etc
| isAlgTyCon tycon
= do name' <- cloneName 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 -- FIXME: no generics
False -- not GADT syntax
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
-- Vectorise the method type.
typ' <- vectType (varType id)
-- Create a name for the vectorised method.
id' <- cloneId mkVectOcc id typ'
defGlobalVar id id'
-- When we call buildClass in vectTyConDecl, it adds foralls and dictionaries
-- to the types of each method. However, the types we get back from vectType
-- above already already have these, so we need to chop them off here otherwise
-- we'll get two copies in the final version.
let (_tyvars, tyBody) = splitForAllTys typ'
let (_dict, tyRest) = splitFunTy tyBody
return (Var.varName id', 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.
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)
| otherwise
= do
name' <- cloneName 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
where
name = dataConName dc
univ_tvs = dataConUnivTyVars dc
rep_arg_tys = dataConRepArgTys dc
tycon = dataConTyCon dc
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment