1 module VectType ( vectTyCon, vectType, vectTypeEnv,
2 PAInstance, buildPADict )
5 #include "HsVersions.h"
11 import HscTypes ( TypeEnv, extendTypeEnvList, typeEnvTyCons )
20 import FamInstEnv ( FamInst, mkLocalFamInst )
21 import InstEnv ( Instance, mkLocalInstance, instanceDFunId )
24 import BasicTypes ( StrictnessMark(..), OverlapFlag(..), boolToRecFlag )
26 import Id ( mkWildId )
27 import Name ( Name, getOccName )
29 import TysWiredIn ( unitTy, unitTyCon, intTy, intDataCon, unitDataConId )
30 import TysPrim ( intPrimTy )
35 import Util ( singleton )
36 import Digraph ( SCC(..), stronglyConnComp )
40 import Control.Monad ( liftM, liftM2, zipWithM, zipWithM_, mapAndUnzipM )
41 import Data.List ( inits, tails, zipWith4, zipWith5 )
43 -- ----------------------------------------------------------------------------
46 vectTyCon :: TyCon -> VM TyCon
48 | isFunTyCon tc = builtin closureTyCon
49 | isBoxedTupleTyCon tc = return tc
50 | isUnLiftedTyCon tc = return tc
54 Just tc' -> return tc'
56 -- FIXME: just for now
57 Nothing -> pprTrace "ccTyCon:" (ppr tc) $ return tc
59 vectType :: Type -> VM Type
60 vectType ty | Just ty' <- coreView ty = vectType ty'
61 vectType (TyVarTy tv) = return $ TyVarTy tv
62 vectType (AppTy ty1 ty2) = liftM2 AppTy (vectType ty1) (vectType ty2)
63 vectType (TyConApp tc tys) = liftM2 TyConApp (vectTyCon tc) (mapM vectType tys)
64 vectType (FunTy ty1 ty2) = liftM2 TyConApp (builtin closureTyCon)
65 (mapM vectType [ty1,ty2])
66 vectType ty@(ForAllTy _ _)
68 mdicts <- mapM paDictArgType tyvars
69 mono_ty' <- vectType mono_ty
70 return $ tyvars `mkForAllTys` ([dict | Just dict <- mdicts] `mkFunTys` mono_ty')
72 (tyvars, mono_ty) = splitForAllTys ty
74 vectType ty = pprPanic "vectType:" (ppr ty)
76 -- ----------------------------------------------------------------------------
79 type TyConGroup = ([TyCon], UniqSet TyCon)
81 data PAInstance = PAInstance {
83 , painstOrigTyCon :: TyCon
84 , painstVectTyCon :: TyCon
85 , painstArrTyCon :: TyCon
88 vectTypeEnv :: TypeEnv -> VM (TypeEnv, [FamInst], [(Var, CoreExpr)])
91 cs <- readGEnv $ mk_map . global_tycons
92 let (conv_tcs, keep_tcs) = classifyTyCons cs groups
93 keep_dcs = concatMap tyConDataCons keep_tcs
94 zipWithM_ defTyCon keep_tcs keep_tcs
95 zipWithM_ defDataCon keep_dcs keep_dcs
96 new_tcs <- vectTyConDecls conv_tcs
98 let orig_tcs = keep_tcs ++ conv_tcs
99 vect_tcs = keep_tcs ++ new_tcs
101 repr_tcs <- zipWithM buildPReprTyCon orig_tcs vect_tcs
102 parr_tcs <- zipWithM buildPArrayTyCon orig_tcs vect_tcs
103 dfuns <- mapM mkPADFun vect_tcs
104 defTyConPAs (zip vect_tcs dfuns)
105 binds <- sequence (zipWith5 buildTyConBindings orig_tcs
111 let all_new_tcs = new_tcs ++ repr_tcs ++ parr_tcs
113 let new_env = extendTypeEnvList env
114 (map ATyCon all_new_tcs
115 ++ [ADataCon dc | tc <- all_new_tcs
116 , dc <- tyConDataCons tc])
118 return (new_env, map mkLocalFamInst (repr_tcs ++ parr_tcs), concat binds)
120 tycons = typeEnvTyCons env
121 groups = tyConGroups tycons
123 mk_map env = listToUFM_Directly [(u, getUnique n /= u) | (u,n) <- nameEnvUniqueElts env]
125 keep_tc tc = let dcs = tyConDataCons tc
127 defTyCon tc tc >> zipWithM_ defDataCon dcs dcs
130 vectTyConDecls :: [TyCon] -> VM [TyCon]
131 vectTyConDecls tcs = fixV $ \tcs' ->
133 mapM_ (uncurry defTyCon) (lazy_zip tcs tcs')
134 mapM vectTyConDecl tcs
137 lazy_zip (x:xs) ~(y:ys) = (x,y) : lazy_zip xs ys
139 vectTyConDecl :: TyCon -> VM TyCon
142 name' <- cloneName mkVectTyConOcc name
143 rhs' <- vectAlgTyConRhs (algTyConRhs tc)
145 liftDs $ buildAlgTyCon name'
147 [] -- no stupid theta
149 rec_flag -- FIXME: is this ok?
150 False -- FIXME: no generics
151 False -- not GADT syntax
152 Nothing -- not a family instance
155 tyvars = tyConTyVars tc
156 rec_flag = boolToRecFlag (isRecursiveTyCon tc)
158 vectAlgTyConRhs :: AlgTyConRhs -> VM AlgTyConRhs
159 vectAlgTyConRhs (DataTyCon { data_cons = data_cons
163 data_cons' <- mapM vectDataCon data_cons
164 zipWithM_ defDataCon data_cons data_cons'
165 return $ DataTyCon { data_cons = data_cons'
169 vectDataCon :: DataCon -> VM DataCon
171 | not . null $ dataConExTyVars dc = pprPanic "vectDataCon: existentials" (ppr dc)
172 | not . null $ dataConEqSpec dc = pprPanic "vectDataCon: eq spec" (ppr dc)
175 name' <- cloneName mkVectDataConOcc name
176 tycon' <- vectTyCon tycon
177 arg_tys <- mapM vectType rep_arg_tys
179 liftDs $ buildDataCon name'
181 (map (const NotMarkedStrict) arg_tys)
182 [] -- no labelled fields
184 [] -- no existential tvs for now
185 [] -- no eq spec for now
190 name = dataConName dc
191 univ_tvs = dataConUnivTyVars dc
192 rep_arg_tys = dataConRepArgTys dc
193 tycon = dataConTyCon dc
195 mk_fam_inst :: TyCon -> TyCon -> (TyCon, [Type])
196 mk_fam_inst fam_tc arg_tc
197 = (fam_tc, [mkTyConApp arg_tc . mkTyVarTys $ tyConTyVars arg_tc])
199 buildPReprTyCon :: TyCon -> TyCon -> VM TyCon
200 buildPReprTyCon orig_tc vect_tc
202 name <- cloneName mkPReprTyConOcc (tyConName orig_tc)
203 rhs_ty <- buildPReprType vect_tc
204 prepr_tc <- builtin preprTyCon
205 liftDs $ buildSynTyCon name
207 (SynonymTyCon rhs_ty)
208 (Just $ mk_fam_inst prepr_tc vect_tc)
210 tyvars = tyConTyVars vect_tc
213 data Repr = ProdRepr {
214 prod_components :: [Type]
215 , prod_tycon :: TyCon
216 , prod_data_con :: DataCon
217 , prod_arr_tycon :: TyCon
218 , prod_arr_data_con :: DataCon
222 sum_components :: [Repr]
224 , sum_arr_tycon :: TyCon
225 , sum_arr_data_con :: DataCon
232 , void_bottom :: CoreExpr
238 tycon <- builtin voidTyCon
239 var <- builtin voidVar
242 , void_bottom = Var var
245 unboxedProductRepr :: [Type] -> VM Repr
246 unboxedProductRepr [] = voidRepr
247 unboxedProductRepr [ty] = return $ IdRepr ty
248 unboxedProductRepr tys = boxedProductRepr tys
250 boxedProductRepr :: [Type] -> VM Repr
253 tycon <- builtin (prodTyCon arity)
254 let [data_con] = tyConDataCons tycon
256 (arr_tycon, _) <- parrayReprTyCon $ mkTyConApp tycon tys
257 let [arr_data_con] = tyConDataCons arr_tycon
260 prod_components = tys
262 , prod_data_con = data_con
263 , prod_arr_tycon = arr_tycon
264 , prod_arr_data_con = arr_data_con
269 sumRepr :: [Repr] -> VM Repr
270 sumRepr [] = voidRepr
271 sumRepr [repr] = boxRepr repr
274 tycon <- builtin (sumTyCon arity)
275 (arr_tycon, _) <- parrayReprTyCon
279 let [arr_data_con] = tyConDataCons arr_tycon
282 sum_components = reprs
284 , sum_arr_tycon = arr_tycon
285 , sum_arr_data_con = arr_data_con
290 splitSumRepr :: Repr -> [Repr]
291 splitSumRepr (SumRepr { sum_components = reprs }) = reprs
292 splitSumRepr repr = [repr]
294 boxRepr :: Repr -> VM Repr
295 boxRepr (VoidRepr {}) = boxedProductRepr []
296 boxRepr (IdRepr ty) = boxedProductRepr [ty]
297 boxRepr repr = return repr
299 reprType :: Repr -> Type
300 reprType (ProdRepr { prod_tycon = tycon, prod_components = tys })
301 = mkTyConApp tycon tys
302 reprType (SumRepr { sum_tycon = tycon, sum_components = reprs })
303 = mkTyConApp tycon (map reprType reprs)
304 reprType (IdRepr ty) = ty
305 reprType (VoidRepr { void_tycon = tycon }) = mkTyConApp tycon []
307 arrReprType :: Repr -> VM Type
308 arrReprType = mkPArrayType . reprType
310 arrShapeTys :: Repr -> VM [Type]
311 arrShapeTys (SumRepr {})
313 int_arr <- builtin parrayIntPrimTyCon
314 return [intPrimTy, mkTyConApp int_arr [], mkTyConApp int_arr []]
315 arrShapeTys (ProdRepr {}) = return [intPrimTy]
316 arrShapeTys (IdRepr _) = return []
317 arrShapeTys (VoidRepr {}) = return [intPrimTy]
319 arrShapeVars :: Repr -> VM [Var]
320 arrShapeVars repr = mapM (newLocalVar FSLIT("sh")) =<< arrShapeTys repr
322 replicateShape :: Repr -> CoreExpr -> CoreExpr -> VM [CoreExpr]
323 replicateShape (ProdRepr {}) len _ = return [len]
324 replicateShape (SumRepr {}) len tag
326 rep <- builtin replicatePAIntPrimVar
327 up <- builtin upToPAIntPrimVar
328 return [len, Var rep `mkApps` [len, tag], Var up `App` len]
329 replicateShape (IdRepr _) _ _ = return []
330 replicateShape (VoidRepr {}) len _ = return [len]
332 emptyArrRepr :: Repr -> VM [CoreExpr]
333 emptyArrRepr (SumRepr { sum_components = prods })
334 = liftM concat $ mapM emptyArrRepr prods
335 emptyArrRepr (ProdRepr { prod_components = [] })
336 = return [Var unitDataConId]
337 emptyArrRepr (ProdRepr { prod_components = tys })
339 emptyArrRepr (IdRepr ty)
340 = liftM singleton $ emptyPA ty
341 emptyArrRepr (VoidRepr { void_tycon = tycon })
342 = liftM singleton $ emptyPA (mkTyConApp tycon [])
344 arrReprTys :: Repr -> VM [Type]
345 arrReprTys (SumRepr { sum_components = reprs })
346 = liftM concat $ mapM arrReprTys reprs
347 arrReprTys (ProdRepr { prod_components = [] })
349 arrReprTys (ProdRepr { prod_components = tys })
350 = mapM mkPArrayType tys
351 arrReprTys (IdRepr ty)
352 = liftM singleton $ mkPArrayType ty
353 arrReprTys (VoidRepr { void_tycon = tycon })
354 = liftM singleton $ mkPArrayType (mkTyConApp tycon [])
356 arrReprTys' :: Repr -> VM [[Type]]
357 arrReprTys' (SumRepr { sum_components = reprs })
358 = mapM arrReprTys reprs
359 arrReprTys' repr = liftM singleton $ arrReprTys repr
361 arrReprVars :: Repr -> VM [[Var]]
363 = mapM (mapM (newLocalVar FSLIT("rs"))) =<< arrReprTys' repr
365 mkRepr :: TyCon -> VM Repr
367 = sumRepr =<< mapM unboxedProductRepr rep_tys
369 rep_tys = map dataConRepArgTys $ tyConDataCons vect_tc
371 buildPReprType :: TyCon -> VM Type
372 buildPReprType = liftM reprType . mkRepr
374 buildToPRepr :: Repr -> TyCon -> TyCon -> TyCon -> VM CoreExpr
375 buildToPRepr repr vect_tc prepr_tc _
377 arg <- newLocalVar FSLIT("x") arg_ty
378 result <- to_repr repr (Var arg)
381 . wrapFamInstBody prepr_tc var_tys
384 var_tys = mkTyVarTys $ tyConTyVars vect_tc
385 arg_ty = mkTyConApp vect_tc var_tys
386 res_ty = reprType repr
388 cons = tyConDataCons vect_tc
391 to_repr (SumRepr { sum_components = prods
392 , sum_tycon = tycon })
395 (vars, bodies) <- mapAndUnzipM to_unboxed prods
396 return . Case expr (mkWildId (exprType expr)) res_ty
397 $ zipWith4 mk_alt cons vars (tyConDataCons tycon) bodies
399 mk_alt con vars sum_con body
400 = (DataAlt con, vars, mkConApp sum_con (ty_args ++ [body]))
402 ty_args = map (Type . reprType) prods
406 (vars, body) <- to_unboxed prod
407 return $ Case expr (mkWildId (exprType expr)) res_ty
408 [(DataAlt con, vars, body)]
410 to_unboxed (ProdRepr { prod_components = tys
411 , prod_data_con = data_con })
413 vars <- mapM (newLocalVar FSLIT("r")) tys
414 return (vars, mkConApp data_con (map Type tys ++ map Var vars))
416 to_unboxed (IdRepr ty)
418 var <- newLocalVar FSLIT("y") ty
419 return ([var], Var var)
421 to_unboxed (VoidRepr { void_bottom = bottom })
422 = return ([], bottom)
425 buildFromPRepr :: Repr -> TyCon -> TyCon -> TyCon -> VM CoreExpr
426 buildFromPRepr repr vect_tc prepr_tc _
428 arg_ty <- mkPReprType res_ty
429 arg <- newLocalVar FSLIT("x") arg_ty
433 $ unwrapFamInstScrut prepr_tc var_tys (Var arg)
435 var_tys = mkTyVarTys $ tyConTyVars vect_tc
436 res_ty = mkTyConApp vect_tc var_tys
438 cons = map (`mkConApp` map Type var_tys) (tyConDataCons vect_tc)
441 from_repr repr@(SumRepr { sum_components = prods
442 , sum_tycon = tycon })
445 vars <- mapM (newLocalVar FSLIT("x")) (map reprType prods)
446 bodies <- sequence . zipWith3 from_unboxed prods cons
448 return . Case expr (mkWildId (reprType repr)) res_ty
449 $ zipWith3 sum_alt (tyConDataCons tycon) vars bodies
451 sum_alt data_con var body = (DataAlt data_con, [var], body)
453 from_repr repr expr = from_unboxed repr con expr
455 from_unboxed prod@(ProdRepr { prod_components = tys
456 , prod_data_con = data_con })
460 vars <- mapM (newLocalVar FSLIT("y")) tys
461 return $ Case expr (mkWildId (reprType prod)) res_ty
462 [(DataAlt data_con, vars, con `mkVarApps` vars)]
464 from_unboxed (IdRepr _) con expr
465 = return $ con `App` expr
467 from_unboxed (VoidRepr {}) con expr
470 buildToArrPRepr :: Repr -> TyCon -> TyCon -> TyCon -> VM CoreExpr
471 buildToArrPRepr repr vect_tc prepr_tc arr_tc
473 arg_ty <- mkPArrayType el_ty
474 arg <- newLocalVar FSLIT("xs") arg_ty
476 res_ty <- mkPArrayType (reprType repr)
478 shape_vars <- arrShapeVars repr
479 repr_vars <- arrReprVars repr
481 parray_co <- mkBuiltinCo parrayTyCon
483 let Just repr_co = tyConFamilyCoercion_maybe prepr_tc
484 co = mkAppCoercion parray_co
486 $ mkTyConApp repr_co var_tys
488 scrut = unwrapFamInstScrut arr_tc var_tys (Var arg)
490 result <- to_repr shape_vars repr_vars repr
494 $ Case scrut (mkWildId (mkTyConApp arr_tc var_tys)) res_ty
495 [(DataAlt arr_dc, shape_vars ++ concat repr_vars, result)]
497 var_tys = mkTyVarTys $ tyConTyVars vect_tc
498 el_ty = mkTyConApp vect_tc var_tys
500 [arr_dc] = tyConDataCons arr_tc
502 to_repr shape_vars@(len_var : _)
504 (SumRepr { sum_components = prods
505 , sum_arr_tycon = tycon
506 , sum_arr_data_con = data_con })
508 exprs <- zipWithM to_prod repr_vars prods
510 return . wrapFamInstBody tycon tys
512 $ map Type tys ++ map Var shape_vars ++ exprs
514 tys = map reprType prods
518 (ProdRepr { prod_components = tys
519 , prod_arr_tycon = tycon
520 , prod_arr_data_con = data_con })
521 = return . wrapFamInstBody tycon tys
523 $ map Type tys ++ map Var (len_var : repr_vars)
525 to_prod repr_vars@(r : _)
526 (ProdRepr { prod_components = tys
527 , prod_arr_tycon = tycon
528 , prod_arr_data_con = data_con })
530 len <- lengthPA (Var r)
531 return . wrapFamInstBody tycon tys
533 $ map Type tys ++ len : map Var repr_vars
535 to_prod [var] (IdRepr ty) = return (Var var)
536 to_prod [var] (VoidRepr {}) = return (Var var)
539 buildFromArrPRepr :: Repr -> TyCon -> TyCon -> TyCon -> VM CoreExpr
540 buildFromArrPRepr repr vect_tc prepr_tc arr_tc
542 arg_ty <- mkPArrayType =<< mkPReprType el_ty
543 arg <- newLocalVar FSLIT("xs") arg_ty
545 res_ty <- mkPArrayType el_ty
547 shape_vars <- arrShapeVars repr
548 repr_vars <- arrReprVars repr
550 parray_co <- mkBuiltinCo parrayTyCon
552 let Just repr_co = tyConFamilyCoercion_maybe prepr_tc
553 co = mkAppCoercion parray_co
554 $ mkTyConApp repr_co var_tys
556 scrut = mkCoerce co (Var arg)
558 result = wrapFamInstBody arr_tc var_tys
560 $ map Type var_tys ++ map Var (shape_vars ++ concat repr_vars)
563 (from_repr repr scrut shape_vars repr_vars res_ty result)
565 var_tys = mkTyVarTys $ tyConTyVars vect_tc
566 el_ty = mkTyConApp vect_tc var_tys
568 [arr_dc] = tyConDataCons arr_tc
570 from_repr (SumRepr { sum_components = prods
571 , sum_arr_tycon = tycon
572 , sum_arr_data_con = data_con })
579 vars <- mapM (newLocalVar FSLIT("xs")) =<< mapM arrReprType prods
580 result <- go prods repr_vars vars body
582 let scrut = unwrapFamInstScrut tycon ty_args expr
583 return . Case scrut (mkWildId scrut_ty) res_ty
584 $ [(DataAlt data_con, shape_vars ++ vars, result)]
586 ty_args = map reprType prods
587 scrut_ty = mkTyConApp tycon ty_args
589 go [] [] [] body = return body
590 go (prod : prods) (repr_vars : rss) (var : vars) body
592 shape_vars <- mapM (newLocalVar FSLIT("s")) =<< arrShapeTys prod
594 from_prod prod (Var var) shape_vars repr_vars res_ty
595 =<< go prods rss vars body
597 from_repr repr expr shape_vars [repr_vars] res_ty body
598 = from_prod repr expr shape_vars repr_vars res_ty body
600 from_prod prod@(ProdRepr { prod_components = tys
601 , prod_arr_tycon = tycon
602 , prod_arr_data_con = data_con })
609 let scrut = unwrapFamInstScrut tycon tys expr
610 scrut_ty = mkTyConApp tycon tys
611 ty <- arrReprType prod
613 return $ Case scrut (mkWildId scrut_ty) res_ty
614 [(DataAlt data_con, shape_vars ++ repr_vars, body)]
616 from_prod (IdRepr ty)
622 = return $ Let (NonRec repr_var expr) body
624 from_prod (VoidRepr {})
630 = return $ Let (NonRec repr_var expr) body
632 buildPRDictRepr :: Repr -> VM CoreExpr
633 buildPRDictRepr (VoidRepr { void_tycon = tycon })
634 = prDFunOfTyCon tycon
635 buildPRDictRepr (IdRepr ty) = mkPR ty
636 buildPRDictRepr (ProdRepr {
637 prod_components = tys
642 dfun <- prDFunOfTyCon tycon
643 return $ dfun `mkTyApps` tys `mkApps` prs
645 buildPRDictRepr (SumRepr {
646 sum_components = prods
647 , sum_tycon = tycon })
649 prs <- mapM buildPRDictRepr prods
650 dfun <- prDFunOfTyCon tycon
651 return $ dfun `mkTyApps` map reprType prods `mkApps` prs
653 buildPRDict :: Repr -> TyCon -> TyCon -> TyCon -> VM CoreExpr
654 buildPRDict repr vect_tc prepr_tc _
656 dict <- buildPRDictRepr repr
658 pr_co <- mkBuiltinCo prTyCon
659 let co = mkAppCoercion pr_co
661 $ mkTyConApp arg_co var_tys
663 return $ mkCoerce co dict
665 var_tys = mkTyVarTys $ tyConTyVars vect_tc
667 Just arg_co = tyConFamilyCoercion_maybe prepr_tc
669 buildPArrayTyCon :: TyCon -> TyCon -> VM TyCon
670 buildPArrayTyCon orig_tc vect_tc = fixV $ \repr_tc ->
672 name' <- cloneName mkPArrayTyConOcc orig_name
673 rhs <- buildPArrayTyConRhs orig_name vect_tc repr_tc
674 parray <- builtin parrayTyCon
676 liftDs $ buildAlgTyCon name'
678 [] -- no stupid theta
680 rec_flag -- FIXME: is this ok?
681 False -- FIXME: no generics
682 False -- not GADT syntax
683 (Just $ mk_fam_inst parray vect_tc)
685 orig_name = tyConName orig_tc
686 tyvars = tyConTyVars vect_tc
687 rec_flag = boolToRecFlag (isRecursiveTyCon vect_tc)
690 buildPArrayTyConRhs :: Name -> TyCon -> TyCon -> VM AlgTyConRhs
691 buildPArrayTyConRhs orig_name vect_tc repr_tc
693 data_con <- buildPArrayDataCon orig_name vect_tc repr_tc
694 return $ DataTyCon { data_cons = [data_con], is_enum = False }
696 buildPArrayDataCon :: Name -> TyCon -> TyCon -> VM DataCon
697 buildPArrayDataCon orig_name vect_tc repr_tc
699 dc_name <- cloneName mkPArrayDataConOcc orig_name
700 repr <- mkRepr vect_tc
702 shape_tys <- arrShapeTys repr
703 repr_tys <- arrReprTys repr
705 let tys = shape_tys ++ repr_tys
707 liftDs $ buildDataCon dc_name
709 (map (const NotMarkedStrict) tys)
710 [] -- no field labels
711 (tyConTyVars vect_tc)
712 [] -- no existentials
718 mkPADFun :: TyCon -> VM Var
720 = newExportedVar (mkPADFunOcc $ getOccName vect_tc) =<< paDFunType vect_tc
722 buildTyConBindings :: TyCon -> TyCon -> TyCon -> TyCon -> Var
723 -> VM [(Var, CoreExpr)]
724 buildTyConBindings orig_tc vect_tc prepr_tc arr_tc dfun
726 repr <- mkRepr vect_tc
727 vectDataConWorkers repr orig_tc vect_tc arr_tc
728 dict <- buildPADict repr vect_tc prepr_tc arr_tc dfun
730 return $ (dfun, dict) : binds
732 orig_dcs = tyConDataCons orig_tc
733 vect_dcs = tyConDataCons vect_tc
734 [arr_dc] = tyConDataCons arr_tc
736 repr_tys = map dataConRepArgTys vect_dcs
738 vectDataConWorkers :: Repr -> TyCon -> TyCon -> TyCon
740 vectDataConWorkers repr orig_tc vect_tc arr_tc
743 . zipWith3 def_worker (tyConDataCons orig_tc) rep_tys
744 $ zipWith4 mk_data_con (tyConDataCons vect_tc)
748 mapM_ (uncurry hoistBinding) bs
750 tyvars = tyConTyVars vect_tc
751 var_tys = mkTyVarTys tyvars
752 ty_args = map Type var_tys
754 res_ty = mkTyConApp vect_tc var_tys
756 rep_tys = map dataConRepArgTys $ tyConDataCons vect_tc
757 reprs = splitSumRepr repr
759 [arr_dc] = tyConDataCons arr_tc
761 mk_data_con con tys pre post
762 = liftM2 (,) (vect_data_con con)
763 (lift_data_con tys pre post (mkDataConTag con))
765 vect_data_con con = return $ mkConApp con ty_args
766 lift_data_con tys pre_reprs post_reprs tag
768 len <- builtin liftingContext
769 args <- mapM (newLocalVar FSLIT("xs"))
770 =<< mapM mkPArrayType tys
772 shape <- replicateShape repr (Var len) tag
773 repr <- mk_arr_repr (Var len) (map Var args)
775 pre <- liftM concat $ mapM emptyArrRepr pre_reprs
776 post <- liftM concat $ mapM emptyArrRepr post_reprs
778 return . mkLams (len : args)
779 . wrapFamInstBody arr_tc var_tys
781 $ ty_args ++ shape ++ pre ++ repr ++ post
785 units <- replicatePA len (Var unitDataConId)
788 mk_arr_repr len arrs = return arrs
790 def_worker data_con arg_tys mk_body
794 . polyAbstract tyvars $ \abstract ->
795 liftM (abstract . vectorised)
796 $ buildClosures tyvars [] arg_tys res_ty mk_body
798 vect_worker <- cloneId mkVectOcc orig_worker (exprType body)
799 defGlobalVar orig_worker vect_worker
800 return (vect_worker, body)
802 orig_worker = dataConWorkId data_con
804 buildPADict :: Repr -> TyCon -> TyCon -> TyCon -> Var -> VM CoreExpr
805 buildPADict repr vect_tc prepr_tc arr_tc dfun
806 = polyAbstract tvs $ \abstract ->
808 meth_binds <- mapM (mk_method repr) paMethods
809 let meth_exprs = map (Var . fst) meth_binds
811 pa_dc <- builtin paDataCon
812 let dict = mkConApp pa_dc (Type (mkTyConApp vect_tc arg_tys) : meth_exprs)
813 body = Let (Rec meth_binds) dict
814 return . mkInlineMe $ abstract body
816 tvs = tyConTyVars arr_tc
817 arg_tys = mkTyVarTys tvs
819 mk_method repr (name, build)
822 body <- build repr vect_tc prepr_tc arr_tc
823 var <- newLocalVar name (exprType body)
824 return (var, mkInlineMe body)
826 paMethods = [(FSLIT("toPRepr"), buildToPRepr),
827 (FSLIT("fromPRepr"), buildFromPRepr),
828 (FSLIT("toArrPRepr"), buildToArrPRepr),
829 (FSLIT("fromArrPRepr"), buildFromArrPRepr),
830 (FSLIT("dictPRepr"), buildPRDict)]
832 -- | Split the given tycons into two sets depending on whether they have to be
833 -- converted (first list) or not (second list). The first argument contains
834 -- information about the conversion status of external tycons:
836 -- * tycons which have converted versions are mapped to True
837 -- * tycons which are not changed by vectorisation are mapped to False
838 -- * tycons which can't be converted are not elements of the map
840 classifyTyCons :: UniqFM Bool -> [TyConGroup] -> ([TyCon], [TyCon])
841 classifyTyCons = classify [] []
843 classify conv keep cs [] = (conv, keep)
844 classify conv keep cs ((tcs, ds) : rs)
845 | can_convert && must_convert
846 = classify (tcs ++ conv) keep (cs `addListToUFM` [(tc,True) | tc <- tcs]) rs
848 = classify conv (tcs ++ keep) (cs `addListToUFM` [(tc,False) | tc <- tcs]) rs
850 = classify conv keep cs rs
852 refs = ds `delListFromUniqSet` tcs
854 can_convert = isNullUFM (refs `minusUFM` cs) && all convertable tcs
855 must_convert = foldUFM (||) False (intersectUFM_C const cs refs)
857 convertable tc = isDataTyCon tc && all isVanillaDataCon (tyConDataCons tc)
859 -- | Compute mutually recursive groups of tycons in topological order
861 tyConGroups :: [TyCon] -> [TyConGroup]
862 tyConGroups tcs = map mk_grp (stronglyConnComp edges)
864 edges = [((tc, ds), tc, uniqSetToList ds) | tc <- tcs
865 , let ds = tyConsOfTyCon tc]
867 mk_grp (AcyclicSCC (tc, ds)) = ([tc], ds)
868 mk_grp (CyclicSCC els) = (tcs, unionManyUniqSets dss)
870 (tcs, dss) = unzip els
872 tyConsOfTyCon :: TyCon -> UniqSet TyCon
874 = tyConsOfTypes . concatMap dataConRepArgTys . tyConDataCons
876 tyConsOfType :: Type -> UniqSet TyCon
878 | Just ty' <- coreView ty = tyConsOfType ty'
879 tyConsOfType (TyVarTy v) = emptyUniqSet
880 tyConsOfType (TyConApp tc tys) = extend (tyConsOfTypes tys)
882 extend | isUnLiftedTyCon tc
883 || isTupleTyCon tc = id
885 | otherwise = (`addOneToUniqSet` tc)
887 tyConsOfType (AppTy a b) = tyConsOfType a `unionUniqSets` tyConsOfType b
888 tyConsOfType (FunTy a b) = (tyConsOfType a `unionUniqSets` tyConsOfType b)
889 `addOneToUniqSet` funTyCon
890 tyConsOfType (ForAllTy _ ty) = tyConsOfType ty
891 tyConsOfType other = pprPanic "ClosureConv.tyConsOfType" $ ppr other
893 tyConsOfTypes :: [Type] -> UniqSet TyCon
894 tyConsOfTypes = unionManyUniqSets . map tyConsOfType