Merge /Users/benl/devel/ghc/ghc-head-devel
[ghc.git] / compiler / vectorise / Vectorise / Generic / PData.hs
1
2 -- | Build instance tycons for the PData and PDatas type families.
3 --
4 -- TODO: the PData and PDatas cases are very similar.
5 -- We should be able to factor out the common parts.
6 module Vectorise.Generic.PData
7 ( buildPDataTyCon
8 , buildPDatasTyCon )
9 where
10
11 import Vectorise.Monad
12 import Vectorise.Builtins
13 import Vectorise.Generic.Description
14 import Vectorise.Utils
15
16 import BasicTypes
17 import BuildTyCl
18 import DataCon
19 import TyCon
20 import Type
21 import Name
22 import Util
23 import MonadUtils
24 import Control.Monad
25
26
27 -- buildPDataTyCon ------------------------------------------------------------
28 -- | Build the PData instance tycon for a given type constructor.
29 buildPDataTyCon :: TyCon -> TyCon -> SumRepr -> VM TyCon
30 buildPDataTyCon orig_tc vect_tc repr
31 = fixV $ \repr_tc ->
32 do name' <- mkLocalisedName mkPDataTyConOcc orig_name
33 rhs <- buildPDataTyConRhs orig_name vect_tc repr_tc repr
34 pdata <- builtin pdataTyCon
35
36 liftDs $ buildAlgTyCon name'
37 tyvars
38 [] -- no stupid theta
39 rhs
40 rec_flag -- FIXME: is this ok?
41 False -- not GADT syntax
42 NoParentTyCon
43 (Just $ mk_fam_inst pdata vect_tc)
44 where
45 orig_name = tyConName orig_tc
46 tyvars = tyConTyVars vect_tc
47 rec_flag = boolToRecFlag (isRecursiveTyCon vect_tc)
48
49
50 buildPDataTyConRhs :: Name -> TyCon -> TyCon -> SumRepr -> VM AlgTyConRhs
51 buildPDataTyConRhs orig_name vect_tc repr_tc repr
52 = do data_con <- buildPDataDataCon orig_name vect_tc repr_tc repr
53 return $ DataTyCon { data_cons = [data_con], is_enum = False }
54
55
56 buildPDataDataCon :: Name -> TyCon -> TyCon -> SumRepr -> VM DataCon
57 buildPDataDataCon orig_name vect_tc repr_tc repr
58 = do let tvs = tyConTyVars vect_tc
59 dc_name <- mkLocalisedName mkPDataDataConOcc orig_name
60 comp_tys <- mkSumTys mkPDataType repr
61
62 liftDs $ buildDataCon dc_name
63 False -- not infix
64 (map (const HsNoBang) comp_tys)
65 [] -- no field labels
66 tvs
67 [] -- no existentials
68 [] -- no eq spec
69 [] -- no context
70 comp_tys
71 (mkFamilyTyConApp repr_tc (mkTyVarTys tvs))
72 repr_tc
73
74
75 -- buildPDatasTyCon -----------------------------------------------------------
76 -- | Build the PDatas instance tycon for a given type constructor.
77 buildPDatasTyCon :: TyCon -> TyCon -> SumRepr -> VM TyCon
78 buildPDatasTyCon orig_tc vect_tc repr
79 = fixV $ \repr_tc ->
80 do name' <- mkLocalisedName mkPDatasTyConOcc orig_name
81 rhs <- buildPDatasTyConRhs orig_name vect_tc repr_tc repr
82 pdatas <- builtin pdatasTyCon
83
84 liftDs $ buildAlgTyCon name'
85 tyvars
86 [] -- no stupid theta
87 rhs
88 rec_flag -- FIXME: is this ok?
89 False -- not GADT syntax
90 NoParentTyCon
91 (Just $ mk_fam_inst pdatas vect_tc)
92 where
93 orig_name = tyConName orig_tc
94 tyvars = tyConTyVars vect_tc
95 rec_flag = boolToRecFlag (isRecursiveTyCon vect_tc)
96
97
98 buildPDatasTyConRhs :: Name -> TyCon -> TyCon -> SumRepr -> VM AlgTyConRhs
99 buildPDatasTyConRhs orig_name vect_tc repr_tc repr
100 = do data_con <- buildPDatasDataCon orig_name vect_tc repr_tc repr
101 return $ DataTyCon { data_cons = [data_con], is_enum = False }
102
103
104 buildPDatasDataCon :: Name -> TyCon -> TyCon -> SumRepr -> VM DataCon
105 buildPDatasDataCon orig_name vect_tc repr_tc repr
106 = do let tvs = tyConTyVars vect_tc
107 dc_name <- mkLocalisedName mkPDatasDataConOcc orig_name
108
109 comp_tys <- mkSumTys mkPDatasType repr
110
111 liftDs $ buildDataCon dc_name
112 False -- not infix
113 (map (const HsNoBang) comp_tys)
114 [] -- no field labels
115 tvs
116 [] -- no existentials
117 [] -- no eq spec
118 [] -- no context
119 comp_tys
120 (mkFamilyTyConApp repr_tc (mkTyVarTys tvs))
121 repr_tc
122
123
124 -- Utils ----------------------------------------------------------------------
125 -- | Flatten a SumRepr into a list of data constructor types.
126 mkSumTys
127 :: (Type -> VM Type)
128 -> SumRepr
129 -> VM [Type]
130
131 mkSumTys mkTc repr
132 = sum_tys repr
133 where
134 sum_tys EmptySum = return []
135 sum_tys (UnarySum r) = con_tys r
136 sum_tys (Sum { repr_sel_ty = sel_ty
137 , repr_cons = cons })
138 = liftM (sel_ty :) (concatMapM con_tys cons)
139
140 con_tys (ConRepr _ r) = prod_tys r
141
142 prod_tys EmptyProd = return []
143 prod_tys (UnaryProd r) = liftM singleton (comp_ty r)
144 prod_tys (Prod { repr_comps = comps }) = mapM comp_ty comps
145
146 comp_ty r = mkTc (compOrigType r)
147
148
149 mk_fam_inst :: TyCon -> TyCon -> (TyCon, [Type])
150 mk_fam_inst fam_tc arg_tc
151 = (fam_tc, [mkTyConApp arg_tc . mkTyVarTys $ tyConTyVars arg_tc])