Revert "Generate Typeable info at definition sites"
[ghc.git] / compiler / vectorise / Vectorise / Type / Env.hs
1 {-# LANGUAGE CPP #-}
2
3 -- Vectorise a modules type and class declarations.
4 --
5 -- This produces new type constructors and family instances top be included in the module toplevel
6 -- as well as bindings for worker functions, dfuns, and the like.
7
8 module Vectorise.Type.Env (
9 vectTypeEnv,
10 ) where
11
12 #include "HsVersions.h"
13
14 import Vectorise.Env
15 import Vectorise.Vect
16 import Vectorise.Monad
17 import Vectorise.Builtins
18 import Vectorise.Type.TyConDecl
19 import Vectorise.Type.Classify
20 import Vectorise.Generic.PADict
21 import Vectorise.Generic.PAMethods
22 import Vectorise.Generic.PData
23 import Vectorise.Generic.Description
24 import Vectorise.Utils
25
26 import CoreSyn
27 import CoreUtils
28 import CoreUnfold
29 import DataCon
30 import TyCon
31 import CoAxiom
32 import Type
33 import FamInstEnv
34 import Id
35 import MkId
36 import NameEnv
37 import NameSet
38 import UniqFM
39 import OccName
40 import Unique
41
42 import Util
43 import Outputable
44 import DynFlags
45 import FastString
46 import MonadUtils
47
48 import Control.Monad
49 import Data.Maybe
50 import Data.List
51
52
53 -- Note [Pragmas to vectorise tycons]
54 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
55 --
56 -- All imported type constructors that are not mapped to a vectorised type in the vectorisation map
57 -- (possibly because the defining module was not compiled with vectorisation) may be used in scalar
58 -- code encapsulated in vectorised code. If a such a type constructor 'T' is a member of the
59 -- 'Scalar' class (and hence also of 'PData' and 'PRepr'), it may also be used in vectorised code,
60 -- where 'T' represents itself, but the representation of 'T' still remains opaque in vectorised
61 -- code (i.e., it can only be used in scalar code).
62 --
63 -- An example is the treatment of 'Int'. 'Int's can be used in vectorised code and remain unchanged
64 -- by vectorisation. However, the representation of 'Int' by the 'I#' data constructor wrapping an
65 -- 'Int#' is not exposed in vectorised code. Instead, computations involving the representation need
66 -- to be confined to scalar code.
67 --
68 -- VECTORISE pragmas for type constructors cover four different flavours of vectorising data type
69 -- constructors:
70 --
71 -- (1) Data type constructor 'T' that together with its constructors 'Cn' may be used in vectorised
72 -- code, where 'T' and the 'Cn' are automatically vectorised in the same manner as data types
73 -- declared in a vectorised module. This includes the case where the vectoriser determines that
74 -- the original representation of 'T' may be used in vectorised code (as it does not embed any
75 -- parallel arrays.) This case is for type constructors that are *imported* from a non-
76 -- vectorised module, but that we want to use with full vectorisation support.
77 --
78 -- An example is the treatment of 'Ordering' and '[]'. The former remains unchanged by
79 -- vectorisation, whereas the latter is fully vectorised.
80 --
81 -- 'PData' and 'PRepr' instances are automatically generated by the vectoriser.
82 --
83 -- Type constructors declared with {-# VECTORISE type T #-} are treated in this manner.
84 --
85 -- (2) Data type constructor 'T' that may be used in vectorised code, where 'T' is represented by an
86 -- explicitly given 'Tv', but the representation of 'T' is opaque in vectorised code (i.e., the
87 -- constructors of 'T' may not occur in vectorised code).
88 --
89 -- An example is the treatment of '[::]'. The type '[::]' can be used in vectorised code and is
90 -- vectorised to 'PArray'. However, the representation of '[::]' is not exposed in vectorised
91 -- code. Instead, computations involving the representation need to be confined to scalar code.
92 --
93 -- 'PData' and 'PRepr' instances need to be explicitly supplied for 'T' (they are not generated
94 -- by the vectoriser).
95 --
96 -- Type constructors declared with {-# VECTORISE type T = Tv #-} are treated in this manner
97 -- manner. (The vectoriser never treats a type constructor automatically in this manner.)
98 --
99 -- (3) Data type constructor 'T' that does not contain any parallel arrays and has explicitly
100 -- provided 'PData' and 'PRepr' instances (and maybe also a 'Scalar' instance), which together
101 -- with the type's constructors 'Cn' may be used in vectorised code. The type 'T' and its
102 -- constructors 'Cn' are represented by themselves in vectorised code.
103 --
104 -- An example is 'Bool', which is represented by itself in vectorised code (as it cannot embed
105 -- any parallel arrays). However, we do not want any automatic generation of class and family
106 -- instances, which is why Case (1) does not apply.
107 --
108 -- 'PData' and 'PRepr' instances need to be explicitly supplied for 'T' (they are not generated
109 -- by the vectoriser).
110 --
111 -- Type constructors declared with {-# VECTORISE SCALAR type T #-} are treated in this manner.
112 --
113 -- (4) Data type constructor 'T' that does not contain any parallel arrays and that, in vectorised
114 -- code, is represented by an explicitly given 'Tv', but the representation of 'T' is opaque in
115 -- vectorised code and 'T' is regarded to be scalar — i.e., it may be used in encapsulated
116 -- scalar subcomputations.
117 --
118 -- An example is the treatment of '(->)'. Types '(->)' can be used in vectorised code and are
119 -- vectorised to '(:->)'. However, the representation of '(->)' is not exposed in vectorised
120 -- code. Instead, computations involving the representation need to be confined to scalar code
121 -- and may be part of encapsulated scalar computations.
122 --
123 -- 'PData' and 'PRepr' instances need to be explicitly supplied for 'T' (they are not generated
124 -- by the vectoriser).
125 --
126 -- Type constructors declared with {-# VECTORISE SCALAR type T = Tv #-} are treated in this
127 -- manner. (The vectoriser never treats a type constructor automatically in this manner.)
128 --
129 -- In addition, we have also got a single pragma form for type classes: {-# VECTORISE class C #-}.
130 -- It implies that the class type constructor may be used in vectorised code together with its data
131 -- constructor. We generally produce a vectorised version of the data type and data constructor.
132 -- We do not generate 'PData' and 'PRepr' instances for class type constructors. This pragma is the
133 -- default for all type classes declared in a vectorised module, but the pragma can also be used
134 -- explitly on imported classes.
135
136 -- Note [Vectorising classes]
137 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~
138 --
139 -- We vectorise classes essentially by just vectorising their desugared Core representation, but we
140 -- do generate a 'Class' structure along the way (see 'Vectorise.Type.TyConDecl.vectTyConDecl').
141 --
142 -- Here is an example illustrating the mapping — assume
143 --
144 -- class Num a where
145 -- (+) :: a -> a -> a
146 --
147 -- It desugars to
148 --
149 -- data Num a = D:Num { (+) :: a -> a -> a }
150 --
151 -- which we vectorise to
152 --
153 -- data V:Num a = D:V:Num { ($v+) :: PArray a :-> PArray a :-> PArray a }
154 --
155 -- while adding the following entries to the vectorisation map:
156 --
157 -- tycon : Num --> V:Num
158 -- datacon: D:Num --> D:V:Num
159 -- var : (+) --> ($v+)
160
161 -- |Vectorise type constructor including class type constructors.
162 --
163 vectTypeEnv :: [TyCon] -- Type constructors defined in this module
164 -> [CoreVect] -- All 'VECTORISE [SCALAR] type' declarations in this module
165 -> [CoreVect] -- All 'VECTORISE class' declarations in this module
166 -> VM ( [TyCon] -- old TyCons ++ new TyCons
167 , [FamInst] -- New type family instances.
168 , [(Var, CoreExpr)]) -- New top level bindings.
169 vectTypeEnv tycons vectTypeDecls vectClassDecls
170 = do { traceVt "** vectTypeEnv" $ ppr tycons
171
172 ; let -- {-# VECTORISE type T -#} (ONLY the imported tycons)
173 impVectTyCons = ( [tycon | VectType False tycon Nothing <- vectTypeDecls]
174 ++ [tycon | VectClass tycon <- vectClassDecls])
175 \\ tycons
176
177 -- {-# VECTORISE type T = Tv -#} (imported & local tycons with an /RHS/)
178 vectTyConsWithRHS = [ (tycon, rhs)
179 | VectType False tycon (Just rhs) <- vectTypeDecls]
180
181 -- {-# VECTORISE SCALAR type T = Tv -#} (imported & local tycons with an /RHS/)
182 scalarTyConsWithRHS = [ (tycon, rhs)
183 | VectType True tycon (Just rhs) <- vectTypeDecls]
184
185 -- {-# VECTORISE SCALAR type T -#} (imported & local /scalar/ tycons without an RHS)
186 scalarTyConsNoRHS = [tycon | VectType True tycon Nothing <- vectTypeDecls]
187
188 -- Check that is not a VECTORISE SCALAR tycon nor VECTORISE tycons with explicit rhs?
189 vectSpecialTyConNames = mkNameSet . map tyConName $
190 scalarTyConsNoRHS ++
191 map fst (vectTyConsWithRHS ++ scalarTyConsWithRHS)
192 notVectSpecialTyCon tc = not $ (tyConName tc) `elemNameSet` vectSpecialTyConNames
193
194 -- Build a map containing all vectorised type constructor. If the vectorised type
195 -- constructor differs from the original one, then it is mapped to 'True'; if they are
196 -- both the same, then it maps to 'False'.
197 ; vectTyCons <- globalVectTyCons
198 ; let vectTyConBase = mapUFM_Directly isDistinct vectTyCons -- 'True' iff tc /= V[[tc]]
199 isDistinct u tc = u /= getUnique tc
200 vectTyConFlavour = vectTyConBase
201 `plusNameEnv`
202 mkNameEnv [ (tyConName tycon, True)
203 | (tycon, _) <- vectTyConsWithRHS ++ scalarTyConsWithRHS]
204 `plusNameEnv`
205 mkNameEnv [ (tyConName tycon, False) -- original representation
206 | tycon <- scalarTyConsNoRHS]
207
208
209 -- Split the list of 'TyCons' into the ones (1) that we must vectorise and those (2)
210 -- that we could, but don't need to vectorise. Type constructors that are not data
211 -- type constructors or use non-Haskell98 features are being dropped. They may not
212 -- appear in vectorised code. (We also drop the local type constructors appearing in a
213 -- VECTORISE SCALAR pragma or a VECTORISE pragma with an explicit right-hand side, as
214 -- these are being handled separately. NB: Some type constructors may be marked SCALAR
215 -- /and/ have an explicit right-hand side.)
216 --
217 -- Furthermore, 'par_tcs' are those type constructors (converted or not) whose
218 -- definition, directly or indirectly, depends on parallel arrays. Finally, 'drop_tcs'
219 -- are all type constructors that cannot be vectorised.
220 ; parallelTyCons <- (`extendNameSetList` map (tyConName . fst) vectTyConsWithRHS) <$>
221 globalParallelTyCons
222 ; let maybeVectoriseTyCons = filter notVectSpecialTyCon tycons ++ impVectTyCons
223 (conv_tcs, keep_tcs, par_tcs, drop_tcs)
224 = classifyTyCons vectTyConFlavour parallelTyCons maybeVectoriseTyCons
225
226 ; traceVt " known parallel : " $ ppr parallelTyCons
227 ; traceVt " VECT SCALAR : " $ ppr (scalarTyConsNoRHS ++ map fst scalarTyConsWithRHS)
228 ; traceVt " VECT [class] : " $ ppr impVectTyCons
229 ; traceVt " VECT with rhs : " $ ppr (map fst (vectTyConsWithRHS ++ scalarTyConsWithRHS))
230 ; traceVt " -- after classification (local and VECT [class] tycons) --" Outputable.empty
231 ; traceVt " reuse : " $ ppr keep_tcs
232 ; traceVt " convert : " $ ppr conv_tcs
233
234 -- warn the user about unvectorised type constructors
235 ; let explanation = ptext (sLit "(They use unsupported language extensions") $$
236 ptext (sLit "or depend on type constructors that are not vectorised)")
237 drop_tcs_nosyn = filter (not . isTypeFamilyTyCon) .
238 filter (not . isTypeSynonymTyCon) $ drop_tcs
239 ; unless (null drop_tcs_nosyn) $
240 emitVt "Warning: cannot vectorise these type constructors:" $
241 pprQuotedList drop_tcs_nosyn $$ explanation
242
243 ; mapM_ addParallelTyConAndCons $ par_tcs ++ map fst vectTyConsWithRHS
244
245 ; let mapping =
246 -- Type constructors that we found we don't need to vectorise and those
247 -- declared VECTORISE SCALAR /without/ an explicit right-hand side, use the same
248 -- representation in both unvectorised and vectorised code; they are not
249 -- abstract.
250 [(tycon, tycon, False) | tycon <- keep_tcs ++ scalarTyConsNoRHS]
251 -- We do the same for type constructors declared VECTORISE SCALAR /without/
252 -- an explicit right-hand side
253 ++ [(tycon, vTycon, True) | (tycon, vTycon) <- vectTyConsWithRHS ++ scalarTyConsWithRHS]
254 ; syn_tcs <- catMaybes <$> mapM defTyConDataCons mapping
255
256 -- Vectorise all the data type declarations that we can and must vectorise (enter the
257 -- type and data constructors into the vectorisation map on-the-fly.)
258 ; new_tcs <- vectTyConDecls conv_tcs
259
260 ; let dumpTc tc vTc = traceVt "---" (ppr tc <+> text "::" <+> ppr (dataConSig tc) $$
261 ppr vTc <+> text "::" <+> ppr (dataConSig vTc))
262 dataConSig tc | Just dc <- tyConSingleDataCon_maybe tc = dataConRepType dc
263 | otherwise = panic "dataConSig"
264 ; zipWithM_ dumpTc (filter isClassTyCon conv_tcs) (filter isClassTyCon new_tcs)
265
266 -- We don't need new representation types for dictionary constructors. The constructors
267 -- are always fully applied, and we don't need to lift them to arrays as a dictionary
268 -- of a particular type always has the same value.
269 ; let orig_tcs = filter (not . isClassTyCon) $ keep_tcs ++ conv_tcs
270 vect_tcs = filter (not . isClassTyCon) $ keep_tcs ++ new_tcs
271
272 -- Build 'PRepr' and 'PData' instance type constructors and family instances for all
273 -- type constructors with vectorised representations.
274 ; reprs <- mapM tyConRepr vect_tcs
275 ; repr_fis <- zipWith3M buildPReprTyCon orig_tcs vect_tcs reprs
276 ; pdata_fis <- zipWith3M buildPDataTyCon orig_tcs vect_tcs reprs
277 ; pdatas_fis <- zipWith3M buildPDatasTyCon orig_tcs vect_tcs reprs
278
279 ; let fam_insts = repr_fis ++ pdata_fis ++ pdatas_fis
280 repr_axs = map famInstAxiom repr_fis
281 pdata_tcs = famInstsRepTyCons pdata_fis
282 pdatas_tcs = famInstsRepTyCons pdatas_fis
283
284 ; updGEnv $ extendFamEnv fam_insts
285
286 -- Generate workers for the vectorised data constructors, dfuns for the 'PA' instances of
287 -- the vectorised type constructors, and associate the type constructors with their dfuns
288 -- in the global environment. We get back the dfun bindings (which we will subsequently
289 -- inject into the modules toplevel).
290 ; (_, binds) <- fixV $ \ ~(dfuns, _) ->
291 do { defTyConPAs (zipLazy vect_tcs dfuns)
292
293 -- Query the 'PData' instance type constructors for type constructors that have a
294 -- VECTORISE SCALAR type pragma without an explicit right-hand side (this is Item
295 -- (3) of "Note [Pragmas to vectorise tycons]" above).
296 ; pdata_scalar_tcs <- mapM pdataReprTyConExact scalarTyConsNoRHS
297
298 -- Build workers for all vectorised data constructors (except abstract ones)
299 ; sequence_ $
300 zipWith3 vectDataConWorkers (orig_tcs ++ scalarTyConsNoRHS)
301 (vect_tcs ++ scalarTyConsNoRHS)
302 (pdata_tcs ++ pdata_scalar_tcs)
303
304 -- Build a 'PA' dictionary for all type constructors (except abstract ones & those
305 -- defined with an explicit right-hand side where the dictionary is user-supplied)
306 ; dfuns <- sequence $
307 zipWith4 buildTyConPADict
308 vect_tcs
309 repr_axs
310 pdata_tcs
311 pdatas_tcs
312
313 ; binds <- takeHoisted
314 ; return (dfuns, binds)
315 }
316
317 -- Return the vectorised variants of type constructors as well as the generated instance
318 -- type constructors, family instances, and dfun bindings.
319 ; return ( new_tcs ++ pdata_tcs ++ pdatas_tcs ++ syn_tcs
320 , fam_insts, binds)
321 }
322 where
323 addParallelTyConAndCons tycon
324 = do
325 { addGlobalParallelTyCon tycon
326 ; mapM_ addGlobalParallelVar . concatMap dataConImplicitIds . tyConDataCons $ tycon
327 }
328
329 -- Add a mapping from the original to vectorised type constructor to the vectorisation map.
330 -- Unless the type constructor is abstract, also mappings from the orignal's data constructors
331 -- to the vectorised type's data constructors.
332 --
333 -- We have three cases: (1) original and vectorised type constructor are the same, (2) the
334 -- name of the vectorised type constructor is canonical (as prescribed by 'mkVectTyConOcc'), or
335 -- (3) the name is not canonical. In the third case, we additionally introduce a type synonym
336 -- with the canonical name that is set equal to the non-canonical name (so that we find the
337 -- right type constructor when reading vectorisation information from interface files).
338 --
339 defTyConDataCons (origTyCon, vectTyCon, isAbstract)
340 = do
341 { canonName <- mkLocalisedName mkVectTyConOcc origName
342 ; if origName == vectName -- Case (1)
343 || vectName == canonName -- Case (2)
344 then do
345 { defTyCon origTyCon vectTyCon -- T --> vT
346 ; defDataCons -- Ci --> vCi
347 ; return Nothing
348 }
349 else do -- Case (3)
350 { let synTyCon = mkSyn canonName (mkTyConTy vectTyCon) -- type S = vT
351 ; defTyCon origTyCon synTyCon -- T --> S
352 ; defDataCons -- Ci --> vCi
353 ; return $ Just synTyCon
354 }
355 }
356 where
357 origName = tyConName origTyCon
358 vectName = tyConName vectTyCon
359
360 mkSyn canonName ty = mkSynonymTyCon canonName (typeKind ty) [] [] ty
361
362 defDataCons
363 | isAbstract = return ()
364 | otherwise
365 = do { MASSERT(length (tyConDataCons origTyCon) == length (tyConDataCons vectTyCon))
366 ; zipWithM_ defDataCon (tyConDataCons origTyCon) (tyConDataCons vectTyCon)
367 }
368
369
370 -- Helpers --------------------------------------------------------------------
371
372 buildTyConPADict :: TyCon -> CoAxiom Unbranched -> TyCon -> TyCon -> VM Var
373 buildTyConPADict vect_tc prepr_ax pdata_tc pdatas_tc
374 = tyConRepr vect_tc >>= buildPADict vect_tc prepr_ax pdata_tc pdatas_tc
375
376 -- Produce a custom-made worker for the data constructors of a vectorised data type. This includes
377 -- all data constructors that may be used in vectorised code — i.e., all data constructors of data
378 -- types with 'VECTORISE [SCALAR] type' pragmas with an explicit right-hand side. Also adds a mapping
379 -- from the original to vectorised worker into the vectorisation map.
380 --
381 -- FIXME: It's not nice that we need create a special worker after the data constructors has
382 -- already been constructed. Also, I don't think the worker is properly added to the data
383 -- constructor. Seems messy.
384 vectDataConWorkers :: TyCon -> TyCon -> TyCon -> VM ()
385 vectDataConWorkers orig_tc vect_tc arr_tc
386 = do { traceVt "Building vectorised worker for datatype" (ppr orig_tc)
387
388 ; bs <- sequence
389 . zipWith3 def_worker (tyConDataCons orig_tc) rep_tys
390 $ zipWith4 mk_data_con (tyConDataCons vect_tc)
391 rep_tys
392 (inits rep_tys)
393 (tail $ tails rep_tys)
394 ; mapM_ (uncurry hoistBinding) bs
395 }
396 where
397 tyvars = tyConTyVars vect_tc
398 var_tys = mkTyVarTys tyvars
399 ty_args = map Type var_tys
400 res_ty = mkTyConApp vect_tc var_tys
401
402 cons = tyConDataCons vect_tc
403 arity = length cons
404 [arr_dc] = tyConDataCons arr_tc
405
406 rep_tys = map dataConRepArgTys $ tyConDataCons vect_tc
407
408 mk_data_con con tys pre post
409 = do dflags <- getDynFlags
410 liftM2 (,) (vect_data_con con)
411 (lift_data_con tys pre post (mkDataConTag dflags con))
412
413 sel_replicate len tag
414 | arity > 1 = do
415 rep <- builtin (selReplicate arity)
416 return [rep `mkApps` [len, tag]]
417
418 | otherwise = return []
419
420 vect_data_con con = return $ mkConApp con ty_args
421 lift_data_con tys pre_tys post_tys tag
422 = do
423 len <- builtin liftingContext
424 args <- mapM (newLocalVar (fsLit "xs"))
425 =<< mapM mkPDataType tys
426
427 sel <- sel_replicate (Var len) tag
428
429 pre <- mapM emptyPD (concat pre_tys)
430 post <- mapM emptyPD (concat post_tys)
431
432 return . mkLams (len : args)
433 . wrapFamInstBody arr_tc var_tys
434 . mkConApp arr_dc
435 $ ty_args ++ sel ++ pre ++ map Var args ++ post
436
437 def_worker data_con arg_tys mk_body
438 = do
439 arity <- polyArity tyvars
440 body <- closedV
441 . inBind orig_worker
442 . polyAbstract tyvars $ \args ->
443 liftM (mkLams (tyvars ++ args) . vectorised)
444 $ buildClosures tyvars [] [] arg_tys res_ty mk_body
445
446 raw_worker <- mkVectId orig_worker (exprType body)
447 let vect_worker = raw_worker `setIdUnfolding`
448 mkInlineUnfolding (Just arity) body
449 defGlobalVar orig_worker vect_worker
450 return (vect_worker, body)
451 where
452 orig_worker = dataConWorkId data_con