c4308e433f1ef268275c68f2bc2aa573aa6f0809
[ghc.git] / compiler / vectorise / Vectorise / Type / TyConDecl.hs
1 module Vectorise.Type.TyConDecl (
2 vectTyConDecls
3 ) where
4
5 import Vectorise.Type.Type
6 import Vectorise.Monad
7 import BuildTyCl
8 import Class
9 import Type
10 import TyCon
11 import DataCon
12 import BasicTypes
13 import Var
14 import Name
15 import Outputable
16 import Util
17 import Control.Monad
18
19
20 -- |Vectorise some (possibly recursively defined) type constructors.
21 --
22 vectTyConDecls :: [TyCon] -> VM [TyCon]
23 vectTyConDecls tcs = fixV $ \tcs' ->
24 do
25 mapM_ (uncurry defTyCon) (zipLazy tcs tcs')
26 mapM vectTyConDecl tcs
27
28 -- |Vectorise a single type constructor.
29 --
30 vectTyConDecl :: TyCon -> VM TyCon
31 vectTyConDecl tycon
32 -- a type class constructor.
33 -- TODO: check for no stupid theta, fds, assoc types.
34 | isClassTyCon tycon
35 , Just cls <- tyConClass_maybe tycon
36
37 = do -- make the name of the vectorised class tycon.
38 name' <- mkLocalisedName mkVectTyConOcc (tyConName tycon)
39
40 -- vectorise right of definition.
41 rhs' <- vectAlgTyConRhs tycon (algTyConRhs tycon)
42
43 -- vectorise method selectors.
44 -- This also adds a mapping between the original and vectorised method selector
45 -- to the state.
46 methods' <- mapM vectMethod
47 $ [(id, defMethSpecOfDefMeth meth)
48 | (id, meth) <- classOpItems cls]
49
50 -- keep the original recursiveness flag.
51 let rec_flag = boolToRecFlag (isRecursiveTyCon tycon)
52
53 -- Calling buildclass here attaches new quantifiers and dictionaries to the method types.
54 cls' <- liftDs
55 $ buildClass
56 False -- include unfoldings on dictionary selectors.
57 name' -- new name V_T:Class
58 (tyConTyVars tycon) -- keep original type vars
59 [] -- no stupid theta
60 [] -- no functional dependencies
61 [] -- no associated types
62 methods' -- method info
63 rec_flag -- whether recursive
64
65 let tycon' = mkClassTyCon name'
66 (tyConKind tycon)
67 (tyConTyVars tycon)
68 rhs'
69 cls'
70 rec_flag
71
72 return $ tycon'
73
74 -- a regular algebraic type constructor.
75 -- TODO: check for stupid theta, generaics, GADTS etc
76 | isAlgTyCon tycon
77 = do name' <- mkLocalisedName mkVectTyConOcc (tyConName tycon)
78 rhs' <- vectAlgTyConRhs tycon (algTyConRhs tycon)
79 let rec_flag = boolToRecFlag (isRecursiveTyCon tycon)
80
81 liftDs $ buildAlgTyCon
82 name' -- new name
83 (tyConTyVars tycon) -- keep original type vars.
84 [] -- no stupid theta.
85 rhs' -- new constructor defs.
86 rec_flag -- FIXME: is this ok?
87 False -- not GADT syntax
88 NoParentTyCon
89 Nothing -- not a family instance
90
91 -- some other crazy thing that we don't handle.
92 | otherwise
93 = cantVectorise "Can't vectorise type constructor: " (ppr tycon)
94
95
96 -- | Vectorise a class method.
97 vectMethod :: (Id, DefMethSpec) -> VM (Name, DefMethSpec, Type)
98 vectMethod (id, defMeth)
99 = do { -- Vectorise the method type.
100 ; typ' <- vectType (varType id)
101
102 -- Create a name for the vectorised method.
103 ; id' <- mkVectId id typ'
104 ; defGlobalVar id id'
105
106 -- When we call buildClass in vectTyConDecl, it adds foralls and dictionaries
107 -- to the types of each method. However, the types we get back from vectType
108 -- above already already have these, so we need to chop them off here otherwise
109 -- we'll get two copies in the final version.
110 ; let (_tyvars, tyBody) = splitForAllTys typ'
111 ; let (_dict, tyRest) = splitFunTy tyBody
112
113 ; return (Var.varName id', defMeth, tyRest)
114 }
115
116 -- |Vectorise the RHS of an algebraic type.
117 --
118 vectAlgTyConRhs :: TyCon -> AlgTyConRhs -> VM AlgTyConRhs
119 vectAlgTyConRhs _ (DataTyCon { data_cons = data_cons
120 , is_enum = is_enum
121 })
122 = do
123 data_cons' <- mapM vectDataCon data_cons
124 zipWithM_ defDataCon data_cons data_cons'
125 return $ DataTyCon { data_cons = data_cons'
126 , is_enum = is_enum
127 }
128 vectAlgTyConRhs tc _
129 = cantVectorise "Can't vectorise type definition:" (ppr tc)
130
131 -- |Vectorise a data constructor.
132 --
133 -- Vectorises its argument and return types.
134 --
135 vectDataCon :: DataCon -> VM DataCon
136 vectDataCon dc
137 | not . null $ dataConExTyVars dc
138 = cantVectorise "Can't vectorise constructor (existentials):" (ppr dc)
139
140 | not . null $ dataConEqSpec dc
141 = cantVectorise "Can't vectorise constructor (eq spec):" (ppr dc)
142
143 | otherwise
144 = do
145 name' <- mkLocalisedName mkVectDataConOcc name
146 tycon' <- vectTyCon tycon
147 arg_tys <- mapM vectType rep_arg_tys
148
149 liftDs $ buildDataCon
150 name'
151 False -- not infix
152 (map (const HsNoBang) arg_tys) -- strictness annots on args.
153 [] -- no labelled fields
154 univ_tvs -- universally quantified vars
155 [] -- no existential tvs for now
156 [] -- no eq spec for now
157 [] -- no context
158 arg_tys -- argument types
159 (mkFamilyTyConApp tycon' (mkTyVarTys univ_tvs)) -- return type
160 tycon' -- representation tycon
161 where
162 name = dataConName dc
163 univ_tvs = dataConUnivTyVars dc
164 rep_arg_tys = dataConRepArgTys dc
165 tycon = dataConTyCon dc