Make {-# UNPACK #-} work for type/data family invocations
[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 import Vectorise.Env( GlobalEnv( global_fam_inst_env ) )
16
17 import BasicTypes
18 import BuildTyCl
19 import DataCon
20 import TyCon
21 import Type
22 import FamInstEnv
23 import Name
24 import Util
25 import MonadUtils
26 import Control.Monad
27
28
29 -- buildPDataTyCon ------------------------------------------------------------
30 -- | Build the PData instance tycon for a given type constructor.
31 buildPDataTyCon :: TyCon -> TyCon -> SumRepr -> VM FamInst
32 buildPDataTyCon orig_tc vect_tc repr
33 = fixV $ \fam_inst ->
34 do let repr_tc = dataFamInstRepTyCon fam_inst
35 name' <- mkLocalisedName mkPDataTyConOcc orig_name
36 rhs <- buildPDataTyConRhs orig_name vect_tc repr_tc repr
37 pdata <- builtin pdataTyCon
38 buildDataFamInst name' pdata vect_tc rhs
39 where
40 orig_name = tyConName orig_tc
41
42 buildDataFamInst :: Name -> TyCon -> TyCon -> AlgTyConRhs -> VM FamInst
43 buildDataFamInst name' fam_tc vect_tc rhs
44 = do { axiom_name <- mkDerivedName mkInstTyCoOcc name'
45
46 ; let fam_inst = mkDataFamInst axiom_name tyvars fam_tc pat_tys rep_tc
47 ax = famInstAxiom fam_inst
48 pat_tys = [mkTyConApp vect_tc (mkTyVarTys tyvars)]
49 rep_tc = buildAlgTyCon name'
50 tyvars
51 Nothing
52 [] -- no stupid theta
53 rhs
54 rec_flag -- FIXME: is this ok?
55 False -- not GADT syntax
56 (FamInstTyCon ax fam_tc pat_tys)
57 ; return fam_inst }
58 where
59 tyvars = tyConTyVars vect_tc
60 rec_flag = boolToRecFlag (isRecursiveTyCon vect_tc)
61
62 buildPDataTyConRhs :: Name -> TyCon -> TyCon -> SumRepr -> VM AlgTyConRhs
63 buildPDataTyConRhs orig_name vect_tc repr_tc repr
64 = do data_con <- buildPDataDataCon orig_name vect_tc repr_tc repr
65 return $ DataTyCon { data_cons = [data_con], is_enum = False }
66
67
68 buildPDataDataCon :: Name -> TyCon -> TyCon -> SumRepr -> VM DataCon
69 buildPDataDataCon orig_name vect_tc repr_tc repr
70 = do let tvs = tyConTyVars vect_tc
71 dc_name <- mkLocalisedName mkPDataDataConOcc orig_name
72 comp_tys <- mkSumTys repr_sel_ty mkPDataType repr
73 fam_envs <- readGEnv global_fam_inst_env
74 liftDs $ buildDataCon fam_envs dc_name
75 False -- not infix
76 (map (const HsNoBang) comp_tys)
77 [] -- no field labels
78 tvs
79 [] -- no existentials
80 [] -- no eq spec
81 [] -- no context
82 comp_tys
83 (mkFamilyTyConApp repr_tc (mkTyVarTys tvs))
84 repr_tc
85
86
87 -- buildPDatasTyCon -----------------------------------------------------------
88 -- | Build the PDatas instance tycon for a given type constructor.
89 buildPDatasTyCon :: TyCon -> TyCon -> SumRepr -> VM FamInst
90 buildPDatasTyCon orig_tc vect_tc repr
91 = fixV $ \fam_inst ->
92 do let repr_tc = dataFamInstRepTyCon fam_inst
93 name' <- mkLocalisedName mkPDatasTyConOcc orig_name
94 rhs <- buildPDatasTyConRhs orig_name vect_tc repr_tc repr
95 pdatas <- builtin pdatasTyCon
96 buildDataFamInst name' pdatas vect_tc rhs
97 where
98 orig_name = tyConName orig_tc
99
100 buildPDatasTyConRhs :: Name -> TyCon -> TyCon -> SumRepr -> VM AlgTyConRhs
101 buildPDatasTyConRhs orig_name vect_tc repr_tc repr
102 = do data_con <- buildPDatasDataCon orig_name vect_tc repr_tc repr
103 return $ DataTyCon { data_cons = [data_con], is_enum = False }
104
105
106 buildPDatasDataCon :: Name -> TyCon -> TyCon -> SumRepr -> VM DataCon
107 buildPDatasDataCon orig_name vect_tc repr_tc repr
108 = do let tvs = tyConTyVars vect_tc
109 dc_name <- mkLocalisedName mkPDatasDataConOcc orig_name
110
111 comp_tys <- mkSumTys repr_sels_ty mkPDatasType repr
112 fam_envs <- readGEnv global_fam_inst_env
113 liftDs $ buildDataCon fam_envs dc_name
114 False -- not infix
115 (map (const HsNoBang) comp_tys)
116 [] -- no field labels
117 tvs
118 [] -- no existentials
119 [] -- no eq spec
120 [] -- no context
121 comp_tys
122 (mkFamilyTyConApp repr_tc (mkTyVarTys tvs))
123 repr_tc
124
125
126 -- Utils ----------------------------------------------------------------------
127 -- | Flatten a SumRepr into a list of data constructor types.
128 mkSumTys
129 :: (SumRepr -> Type)
130 -> (Type -> VM Type)
131 -> SumRepr
132 -> VM [Type]
133
134 mkSumTys repr_selX_ty mkTc repr
135 = sum_tys repr
136 where
137 sum_tys EmptySum = return []
138 sum_tys (UnarySum r) = con_tys r
139 sum_tys d@(Sum { repr_cons = cons })
140 = liftM (repr_selX_ty d :) (concatMapM con_tys cons)
141
142 con_tys (ConRepr _ r) = prod_tys r
143
144 prod_tys EmptyProd = return []
145 prod_tys (UnaryProd r) = liftM singleton (comp_ty r)
146 prod_tys (Prod { repr_comps = comps }) = mapM comp_ty comps
147
148 comp_ty r = mkTc (compOrigType r)
149
150 {-
151 mk_fam_inst :: TyCon -> TyCon -> (TyCon, [Type])
152 mk_fam_inst fam_tc arg_tc
153 = (fam_tc, [mkTyConApp arg_tc . mkTyVarTys $ tyConTyVars arg_tc])
154 -}
155