Merge remote-tracking branch 'laptop/newcg' into newcg
[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 FamInstEnv
22 import Name
23 import Util
24 import MonadUtils
25 import Control.Monad
26
27
28 -- buildPDataTyCon ------------------------------------------------------------
29 -- | Build the PData instance tycon for a given type constructor.
30 buildPDataTyCon :: TyCon -> TyCon -> SumRepr -> VM FamInst
31 buildPDataTyCon orig_tc vect_tc repr
32 = fixV $ \fam_inst ->
33 do let repr_tc = dataFamInstRepTyCon fam_inst
34 name' <- mkLocalisedName mkPDataTyConOcc orig_name
35 rhs <- buildPDataTyConRhs orig_name vect_tc repr_tc repr
36 pdata <- builtin pdataTyCon
37 buildDataFamInst name' pdata vect_tc rhs
38 where
39 orig_name = tyConName orig_tc
40
41 buildDataFamInst :: Name -> TyCon -> TyCon -> AlgTyConRhs -> VM FamInst
42 buildDataFamInst name' fam_tc vect_tc rhs
43 = do { axiom_name <- mkDerivedName mkInstTyCoOcc name'
44
45 ; let fam_inst = mkDataFamInst axiom_name tyvars fam_tc pat_tys rep_tc
46 ax = famInstAxiom fam_inst
47 pat_tys = [mkTyConApp vect_tc (mkTyVarTys tyvars)]
48 rep_tc = buildAlgTyCon name'
49 tyvars
50 [] -- no stupid theta
51 rhs
52 rec_flag -- FIXME: is this ok?
53 False -- not GADT syntax
54 (FamInstTyCon ax fam_tc pat_tys)
55 ; return fam_inst }
56 where
57 tyvars = tyConTyVars vect_tc
58 rec_flag = boolToRecFlag (isRecursiveTyCon vect_tc)
59
60 buildPDataTyConRhs :: Name -> TyCon -> TyCon -> SumRepr -> VM AlgTyConRhs
61 buildPDataTyConRhs orig_name vect_tc repr_tc repr
62 = do data_con <- buildPDataDataCon orig_name vect_tc repr_tc repr
63 return $ DataTyCon { data_cons = [data_con], is_enum = False }
64
65
66 buildPDataDataCon :: Name -> TyCon -> TyCon -> SumRepr -> VM DataCon
67 buildPDataDataCon orig_name vect_tc repr_tc repr
68 = do let tvs = tyConTyVars vect_tc
69 dc_name <- mkLocalisedName mkPDataDataConOcc orig_name
70 comp_tys <- mkSumTys repr_sel_ty mkPDataType repr
71
72 liftDs $ buildDataCon dc_name
73 False -- not infix
74 (map (const HsNoBang) comp_tys)
75 [] -- no field labels
76 tvs
77 [] -- no existentials
78 [] -- no eq spec
79 [] -- no context
80 comp_tys
81 (mkFamilyTyConApp repr_tc (mkTyVarTys tvs))
82 repr_tc
83
84
85 -- buildPDatasTyCon -----------------------------------------------------------
86 -- | Build the PDatas instance tycon for a given type constructor.
87 buildPDatasTyCon :: TyCon -> TyCon -> SumRepr -> VM FamInst
88 buildPDatasTyCon orig_tc vect_tc repr
89 = fixV $ \fam_inst ->
90 do let repr_tc = dataFamInstRepTyCon fam_inst
91 name' <- mkLocalisedName mkPDatasTyConOcc orig_name
92 rhs <- buildPDatasTyConRhs orig_name vect_tc repr_tc repr
93 pdatas <- builtin pdatasTyCon
94 buildDataFamInst name' pdatas vect_tc rhs
95 where
96 orig_name = tyConName orig_tc
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 repr_sels_ty 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 :: (SumRepr -> Type)
128 -> (Type -> VM Type)
129 -> SumRepr
130 -> VM [Type]
131
132 mkSumTys repr_selX_ty mkTc repr
133 = sum_tys repr
134 where
135 sum_tys EmptySum = return []
136 sum_tys (UnarySum r) = con_tys r
137 sum_tys d@(Sum { repr_cons = cons })
138 = liftM (repr_selX_ty d :) (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])
152 -}