Implement unboxed sum primitive type
[ghc.git] / compiler / vectorise / Vectorise / Type / TyConDecl.hs
1
2 module Vectorise.Type.TyConDecl (
3 vectTyConDecls
4 ) where
5
6 import Vectorise.Type.Type
7 import Vectorise.Monad
8 import Vectorise.Env( GlobalEnv( global_fam_inst_env ) )
9 import BuildTyCl( TcMethInfo, buildClass, buildDataCon, newTyConRepName )
10 import OccName
11 import Class
12 import Type
13 import TyCon
14 import DataCon
15 import DynFlags
16 import BasicTypes( DefMethSpec(..) )
17 import SrcLoc( SrcSpan, noSrcSpan )
18 import Var
19 import Name
20 import Outputable
21 import Util
22 import Control.Monad
23
24
25 -- |Vectorise some (possibly recursively defined) type constructors.
26 --
27 vectTyConDecls :: [TyCon] -> VM [TyCon]
28 vectTyConDecls tcs = fixV $ \tcs' ->
29 do { names' <- mapM (mkLocalisedName mkVectTyConOcc . tyConName) tcs
30 ; mapM_ (uncurry (uncurry defTyConName)) (tcs `zip` names' `zipLazy` tcs')
31 ; zipWithM vectTyConDecl tcs names'
32 }
33
34 -- |Vectorise a single type constructor.
35 --
36 vectTyConDecl :: TyCon -> Name -> VM TyCon
37 vectTyConDecl tycon name'
38
39 -- Type constructor representing a type class
40 | Just cls <- tyConClass_maybe tycon
41 = do { unless (null $ classATs cls) $
42 do dflags <- getDynFlags
43 cantVectorise dflags "Associated types are not yet supported" (ppr cls)
44
45 -- vectorise superclass constraint (types)
46 ; theta' <- mapM vectType (classSCTheta cls)
47
48 -- vectorise method selectors
49 ; let opItems = classOpItems cls
50 Just datacon = tyConSingleDataCon_maybe tycon
51 argTys = dataConRepArgTys datacon -- all selector types
52 opTys = drop (length argTys - length opItems) argTys -- only method types
53 ; methods' <- sequence [ vectMethod id meth ty | ((id, meth), ty) <- zip opItems opTys]
54
55 -- construct the vectorised class (this also creates the class type constructors and its
56 -- data constructor)
57 --
58 -- NB: 'buildClass' attaches new quantifiers and dictionaries to the method types
59 ; cls' <- liftDs $
60 buildClass
61 name' -- new name: "V:Class"
62 (tyConBinders tycon) -- keep original kind
63 (map (const Nominal) (tyConRoles tycon)) -- all role are N for safety
64 theta' -- superclasses
65 (snd . classTvsFds $ cls) -- keep the original functional dependencies
66 [] -- no associated types (for the moment)
67 methods' -- method info
68 (classMinimalDef cls) -- Inherit minimal complete definition from cls
69
70 -- the original dictionary constructor must map to the vectorised one
71 ; let tycon' = classTyCon cls'
72 Just datacon = tyConSingleDataCon_maybe tycon
73 Just datacon' = tyConSingleDataCon_maybe tycon'
74 ; defDataCon datacon datacon'
75
76 -- the original superclass and methods selectors must map to the vectorised ones
77 ; let selIds = classAllSelIds cls
78 selIds' = classAllSelIds cls'
79 ; zipWithM_ defGlobalVar selIds selIds'
80
81 -- return the type constructor of the vectorised class
82 ; return tycon'
83 }
84
85 -- Regular algebraic type constructor — for now, Haskell 2011-style only
86 | isAlgTyCon tycon
87 = do { unless (all isVanillaDataCon (tyConDataCons tycon)) $
88 do dflags <- getDynFlags
89 cantVectorise dflags "Currently only Haskell 2011 datatypes are supported" (ppr tycon)
90
91 -- vectorise the data constructor of the class tycon
92 ; rhs' <- vectAlgTyConRhs tycon (algTyConRhs tycon)
93
94 -- keep the original GADT flags
95 ; let gadt_flag = isGadtSyntaxTyCon tycon
96
97 -- build the vectorised type constructor
98 ; tc_rep_name <- mkDerivedName mkTyConRepOcc name'
99 ; return $ mkAlgTyCon
100 name' -- new name
101 (tyConBinders tycon)
102 (tyConResKind tycon) -- keep original kind
103 (map (const Nominal) (tyConRoles tycon)) -- all roles are N for safety
104 Nothing
105 [] -- no stupid theta
106 rhs' -- new constructor defs
107 (VanillaAlgTyCon tc_rep_name)
108 gadt_flag -- whether in GADT syntax
109 }
110
111 -- some other crazy thing that we don't handle
112 | otherwise
113 = do dflags <- getDynFlags
114 cantVectorise dflags "Can't vectorise exotic type constructor" (ppr tycon)
115
116 -- |Vectorise a class method. (Don't enter it into the vectorisation map yet.)
117 --
118 vectMethod :: Id -> DefMethInfo -> Type -> VM TcMethInfo
119 vectMethod id defMeth ty
120 = do { -- Vectorise the method type.
121 ; ty' <- vectType ty
122
123 -- Create a name for the vectorised method.
124 ; id' <- mkVectId id ty'
125
126 ; return (Var.varName id', ty', defMethSpecOfDefMeth defMeth)
127 }
128
129 -- | Convert a `DefMethInfo` to a `DefMethSpec`, which discards the name field in
130 -- the `DefMeth` constructor of the `DefMeth`.
131 defMethSpecOfDefMeth :: DefMethInfo -> Maybe (DefMethSpec (SrcSpan, Type))
132 defMethSpecOfDefMeth Nothing = Nothing
133 defMethSpecOfDefMeth (Just (_, VanillaDM)) = Just VanillaDM
134 defMethSpecOfDefMeth (Just (_, GenericDM ty)) = Just (GenericDM (noSrcSpan, ty))
135
136 -- |Vectorise the RHS of an algebraic type.
137 --
138 vectAlgTyConRhs :: TyCon -> AlgTyConRhs -> VM AlgTyConRhs
139 vectAlgTyConRhs tc (AbstractTyCon {})
140 = do dflags <- getDynFlags
141 cantVectorise dflags "Can't vectorise imported abstract type" (ppr tc)
142 vectAlgTyConRhs _tc (DataTyCon { data_cons = data_cons
143 , is_enum = is_enum
144 })
145 = do { data_cons' <- mapM vectDataCon data_cons
146 ; zipWithM_ defDataCon data_cons data_cons'
147 ; return $ DataTyCon { data_cons = data_cons'
148 , is_enum = is_enum
149 }
150 }
151
152 vectAlgTyConRhs tc (TupleTyCon { data_con = con })
153 = vectAlgTyConRhs tc (DataTyCon { data_cons = [con], is_enum = False })
154 -- I'm not certain this is what you want to do for tuples,
155 -- but it's the behaviour we had before I refactored the
156 -- representation of AlgTyConRhs to add tuples
157
158 vectAlgTyConRhs tc (SumTyCon { data_cons = cons })
159 = -- FIXME (osa): I'm pretty sure this is broken.. TupleTyCon case is probably
160 -- also broken when the tuple is unboxed.
161 vectAlgTyConRhs tc (DataTyCon { data_cons = cons
162 , is_enum = all (((==) 0) . dataConRepArity) cons })
163
164 vectAlgTyConRhs tc (NewTyCon {})
165 = do dflags <- getDynFlags
166 cantVectorise dflags noNewtypeErr (ppr tc)
167 where
168 noNewtypeErr = "Vectorisation of newtypes not supported yet; please use a 'data' declaration"
169
170 -- |Vectorise a data constructor by vectorising its argument and return types..
171 --
172 vectDataCon :: DataCon -> VM DataCon
173 vectDataCon dc
174 | not . null $ ex_tvs
175 = do dflags <- getDynFlags
176 cantVectorise dflags "Can't vectorise constructor with existential type variables yet" (ppr dc)
177 | not . null $ eq_spec
178 = do dflags <- getDynFlags
179 cantVectorise dflags "Can't vectorise constructor with equality context yet" (ppr dc)
180 | not . null $ dataConFieldLabels dc
181 = do dflags <- getDynFlags
182 cantVectorise dflags "Can't vectorise constructor with labelled fields yet" (ppr dc)
183 | not . null $ theta
184 = do dflags <- getDynFlags
185 cantVectorise dflags "Can't vectorise constructor with constraint context yet" (ppr dc)
186 | otherwise
187 = do { name' <- mkLocalisedName mkVectDataConOcc name
188 ; tycon' <- vectTyCon tycon
189 ; arg_tys <- mapM vectType rep_arg_tys
190 ; let ret_ty = mkFamilyTyConApp tycon' (mkTyVarTys univ_tvs)
191 ; fam_envs <- readGEnv global_fam_inst_env
192 ; rep_nm <- liftDs $ newTyConRepName name'
193 ; liftDs $ buildDataCon fam_envs
194 name'
195 (dataConIsInfix dc) -- infix if the original is
196 rep_nm
197 (dataConSrcBangs dc) -- strictness as original constructor
198 (Just $ dataConImplBangs dc)
199 [] -- no labelled fields for now
200 univ_bndrs -- universally quantified vars
201 [] -- no existential tvs for now
202 [] -- no equalities for now
203 [] -- no context for now
204 arg_tys -- argument types
205 ret_ty -- return type
206 tycon' -- representation tycon
207 }
208 where
209 name = dataConName dc
210 rep_arg_tys = dataConRepArgTys dc
211 tycon = dataConTyCon dc
212 (univ_tvs, ex_tvs, eq_spec, theta, _arg_tys, _res_ty) = dataConFullSig dc
213 univ_bndrs = dataConUnivTyVarBinders dc