1 module VectType ( vectTyCon, vectAndLiftType, vectType, vectTypeEnv,
2 -- arrSumArity, pdataCompTys, pdataCompVars,
11 import HscTypes ( TypeEnv, extendTypeEnvList, typeEnvTyCons )
14 import MkCore ( mkWildCase )
21 import FamInstEnv ( FamInst, mkLocalFamInst )
24 import BasicTypes ( StrictnessMark(..), boolToRecFlag )
25 import Var ( Var, TyVar )
26 import Name ( Name, getOccName )
33 import Digraph ( SCC(..), stronglyConnCompFromEdgedVertices )
38 import Control.Monad ( liftM, liftM2, zipWithM, zipWithM_, mapAndUnzipM )
39 import Data.List ( inits, tails, zipWith4, zipWith5 )
41 -- ----------------------------------------------------------------------------
44 vectTyCon :: TyCon -> VM TyCon
46 | isFunTyCon tc = builtin closureTyCon
47 | isBoxedTupleTyCon tc = return tc
48 | isUnLiftedTyCon tc = return tc
49 | otherwise = maybeCantVectoriseM "Tycon not vectorised:" (ppr tc)
52 vectAndLiftType :: Type -> VM (Type, Type)
53 vectAndLiftType ty | Just ty' <- coreView ty = vectAndLiftType ty'
56 mdicts <- mapM paDictArgType tyvars
57 let dicts = [dict | Just dict <- mdicts]
58 vmono_ty <- vectType mono_ty
59 lmono_ty <- mkPDataType vmono_ty
60 return (abstractType tyvars dicts vmono_ty,
61 abstractType tyvars dicts lmono_ty)
63 (tyvars, mono_ty) = splitForAllTys ty
66 vectType :: Type -> VM Type
67 vectType ty | Just ty' <- coreView ty = vectType ty'
68 vectType (TyVarTy tv) = return $ TyVarTy tv
69 vectType (AppTy ty1 ty2) = liftM2 AppTy (vectType ty1) (vectType ty2)
70 vectType (TyConApp tc tys) = liftM2 TyConApp (vectTyCon tc) (mapM vectType tys)
71 vectType (FunTy ty1 ty2) = liftM2 TyConApp (builtin closureTyCon)
72 (mapM vectAndBoxType [ty1,ty2])
73 vectType ty@(ForAllTy _ _)
75 mdicts <- mapM paDictArgType tyvars
76 mono_ty' <- vectType mono_ty
77 return $ abstractType tyvars [dict | Just dict <- mdicts] mono_ty'
79 (tyvars, mono_ty) = splitForAllTys ty
81 vectType ty = cantVectorise "Can't vectorise type" (ppr ty)
83 vectAndBoxType :: Type -> VM Type
84 vectAndBoxType ty = vectType ty >>= boxType
86 abstractType :: [TyVar] -> [Type] -> Type -> Type
87 abstractType tyvars dicts = mkForAllTys tyvars . mkFunTys dicts
89 -- ----------------------------------------------------------------------------
92 boxType :: Type -> VM Type
94 | Just (tycon, []) <- splitTyConApp_maybe ty
95 , isUnLiftedTyCon tycon
97 r <- lookupBoxedTyCon tycon
99 Just tycon' -> return $ mkTyConApp tycon' []
101 boxType ty = return ty
103 -- ----------------------------------------------------------------------------
106 type TyConGroup = ([TyCon], UniqSet TyCon)
108 vectTypeEnv :: TypeEnv -> VM (TypeEnv, [FamInst], [(Var, CoreExpr)])
111 cs <- readGEnv $ mk_map . global_tycons
112 let (conv_tcs, keep_tcs) = classifyTyCons cs groups
113 keep_dcs = concatMap tyConDataCons keep_tcs
114 zipWithM_ defTyCon keep_tcs keep_tcs
115 zipWithM_ defDataCon keep_dcs keep_dcs
116 new_tcs <- vectTyConDecls conv_tcs
118 let orig_tcs = keep_tcs ++ conv_tcs
119 vect_tcs = keep_tcs ++ new_tcs
121 repr_tcs <- zipWithM buildPReprTyCon orig_tcs vect_tcs
122 pdata_tcs <- zipWithM buildPDataTyCon orig_tcs vect_tcs
123 dfuns <- mapM mkPADFun vect_tcs
124 defTyConPAs (zip vect_tcs dfuns)
125 binds <- sequence (zipWith5 buildTyConBindings orig_tcs
131 let all_new_tcs = new_tcs ++ repr_tcs ++ pdata_tcs
133 let new_env = extendTypeEnvList env
134 (map ATyCon all_new_tcs
135 ++ [ADataCon dc | tc <- all_new_tcs
136 , dc <- tyConDataCons tc])
138 return (new_env, map mkLocalFamInst (repr_tcs ++ pdata_tcs), concat binds)
140 tycons = typeEnvTyCons env
141 groups = tyConGroups tycons
143 mk_map env = listToUFM_Directly [(u, getUnique n /= u) | (u,n) <- nameEnvUniqueElts env]
146 vectTyConDecls :: [TyCon] -> VM [TyCon]
147 vectTyConDecls tcs = fixV $ \tcs' ->
149 mapM_ (uncurry defTyCon) (zipLazy tcs tcs')
150 mapM vectTyConDecl tcs
152 vectTyConDecl :: TyCon -> VM TyCon
155 name' <- cloneName mkVectTyConOcc name
156 rhs' <- vectAlgTyConRhs tc (algTyConRhs tc)
158 liftDs $ buildAlgTyCon name'
160 [] -- no stupid theta
162 rec_flag -- FIXME: is this ok?
163 False -- FIXME: no generics
164 False -- not GADT syntax
165 Nothing -- not a family instance
168 tyvars = tyConTyVars tc
169 rec_flag = boolToRecFlag (isRecursiveTyCon tc)
171 vectAlgTyConRhs :: TyCon -> AlgTyConRhs -> VM AlgTyConRhs
172 vectAlgTyConRhs _ (DataTyCon { data_cons = data_cons
176 data_cons' <- mapM vectDataCon data_cons
177 zipWithM_ defDataCon data_cons data_cons'
178 return $ DataTyCon { data_cons = data_cons'
181 vectAlgTyConRhs tc _ = cantVectorise "Can't vectorise type definition:" (ppr tc)
183 vectDataCon :: DataCon -> VM DataCon
185 | not . null $ dataConExTyVars dc
186 = cantVectorise "Can't vectorise constructor (existentials):" (ppr dc)
187 | not . null $ dataConEqSpec dc
188 = cantVectorise "Can't vectorise constructor (eq spec):" (ppr dc)
191 name' <- cloneName mkVectDataConOcc name
192 tycon' <- vectTyCon tycon
193 arg_tys <- mapM vectType rep_arg_tys
195 liftDs $ buildDataCon name'
197 (map (const NotMarkedStrict) arg_tys)
198 [] -- no labelled fields
200 [] -- no existential tvs for now
201 [] -- no eq spec for now
204 (mkFamilyTyConApp tycon' (mkTyVarTys univ_tvs))
207 name = dataConName dc
208 univ_tvs = dataConUnivTyVars dc
209 rep_arg_tys = dataConRepArgTys dc
210 tycon = dataConTyCon dc
212 mk_fam_inst :: TyCon -> TyCon -> (TyCon, [Type])
213 mk_fam_inst fam_tc arg_tc
214 = (fam_tc, [mkTyConApp arg_tc . mkTyVarTys $ tyConTyVars arg_tc])
216 buildPReprTyCon :: TyCon -> TyCon -> VM TyCon
217 buildPReprTyCon orig_tc vect_tc
219 name <- cloneName mkPReprTyConOcc (tyConName orig_tc)
220 rhs_ty <- buildPReprType vect_tc
221 prepr_tc <- builtin preprTyCon
222 liftDs $ buildSynTyCon name
224 (SynonymTyCon rhs_ty)
226 (Just $ mk_fam_inst prepr_tc vect_tc)
228 tyvars = tyConTyVars vect_tc
230 buildPReprType :: TyCon -> VM Type
231 buildPReprType vect_tc = sum_type . map dataConRepArgTys $ tyConDataCons vect_tc
233 sum_type [] = voidType
234 sum_type [tys] = prod_type tys
236 (sum_tc, _, _, args) <- reprSumTyCons vect_tc
237 return $ mkTyConApp sum_tc args
239 prod_type [] = voidType
240 prod_type [ty] = return ty
242 prod_tc <- builtin (prodTyCon (length tys))
243 return $ mkTyConApp prod_tc tys
245 reprSumTyCons :: TyCon -> VM (TyCon, TyCon, Type, [Type])
246 reprSumTyCons vect_tc
248 tc <- builtin (sumTyCon arity)
249 args <- mapM (prod . dataConRepArgTys) cons
250 (pdata_tc, _) <- pdataReprTyCon (mkTyConApp tc args)
251 sel_ty <- builtin (selTy arity)
252 return (tc, pdata_tc, sel_ty, args)
254 cons = tyConDataCons vect_tc
258 prod [ty] = return ty
260 prod_tc <- builtin (prodTyCon (length tys))
261 return $ mkTyConApp prod_tc tys
263 buildToPRepr :: TyCon -> TyCon -> TyCon -> VM CoreExpr
264 buildToPRepr vect_tc repr_tc _
266 let arg_ty = mkTyConApp vect_tc ty_args
267 res_ty <- mkPReprType arg_ty
268 arg <- newLocalVar (fsLit "x") arg_ty
269 result <- to_sum (Var arg) arg_ty res_ty (tyConDataCons vect_tc)
270 return $ Lam arg result
272 ty_args = mkTyVarTys (tyConTyVars vect_tc)
274 wrap = wrapFamInstBody repr_tc ty_args
278 void <- builtin voidVar
279 return $ wrap (Var void)
281 to_sum arg arg_ty res_ty [con]
283 (prod, vars) <- to_prod (dataConRepArgTys con)
284 return $ mkWildCase arg arg_ty res_ty
285 [(DataAlt con, vars, wrap prod)]
287 to_sum arg arg_ty res_ty cons
289 (prods, vars) <- mapAndUnzipM (to_prod . dataConRepArgTys) cons
290 (sum_tc, _, _, sum_ty_args) <- reprSumTyCons vect_tc
291 let sum_cons = [mkConApp con (map Type sum_ty_args)
292 | con <- tyConDataCons sum_tc]
293 return . mkWildCase arg arg_ty res_ty
294 $ zipWith4 mk_alt cons vars sum_cons prods
296 mk_alt con vars sum_con expr
297 = (DataAlt con, vars, wrap $ sum_con `App` expr)
301 void <- builtin voidVar
302 return (Var void, [])
305 var <- newLocalVar (fsLit "x") ty
306 return (Var var, [var])
309 prod_con <- builtin (prodDataCon (length tys))
310 vars <- newLocalVars (fsLit "x") tys
311 return (mkConApp prod_con (map Type tys ++ map Var vars), vars)
313 buildFromPRepr :: TyCon -> TyCon -> TyCon -> VM CoreExpr
314 buildFromPRepr vect_tc repr_tc _
316 arg_ty <- mkPReprType res_ty
317 arg <- newLocalVar (fsLit "x") arg_ty
319 result <- from_sum (unwrapFamInstScrut repr_tc ty_args (Var arg))
320 (tyConDataCons vect_tc)
321 return $ Lam arg result
323 ty_args = mkTyVarTys (tyConTyVars vect_tc)
324 res_ty = mkTyConApp vect_tc ty_args
326 from_sum _ [] = pprPanic "buildFromPRepr" (ppr vect_tc)
327 from_sum expr [con] = from_prod expr con
330 (sum_tc, _, _, sum_ty_args) <- reprSumTyCons vect_tc
331 let sum_cons = tyConDataCons sum_tc
332 vars <- newLocalVars (fsLit "x") sum_ty_args
333 prods <- zipWithM from_prod (map Var vars) cons
334 return . mkWildCase expr (exprType expr) res_ty
335 $ zipWith3 mk_alt sum_cons vars prods
337 mk_alt con var expr = (DataAlt con, [var], expr)
340 = case dataConRepArgTys con of
341 [] -> return $ apply_con []
342 [_] -> return $ apply_con [expr]
344 prod_con <- builtin (prodDataCon (length tys))
345 vars <- newLocalVars (fsLit "y") tys
346 return $ mkWildCase expr (exprType expr) res_ty
347 [(DataAlt prod_con, vars, apply_con (map Var vars))]
349 apply_con exprs = mkConApp con (map Type ty_args) `mkApps` exprs
351 buildToArrPRepr :: TyCon -> TyCon -> TyCon -> VM CoreExpr
352 buildToArrPRepr vect_tc prepr_tc pdata_tc
354 arg_ty <- mkPDataType el_ty
355 res_ty <- mkPDataType =<< mkPReprType el_ty
356 arg <- newLocalVar (fsLit "xs") arg_ty
358 pdata_co <- mkBuiltinCo pdataTyCon
359 let Just repr_co = tyConFamilyCoercion_maybe prepr_tc
360 co = mkAppCoercion pdata_co
362 $ mkTyConApp repr_co ty_args
364 scrut = unwrapFamInstScrut pdata_tc ty_args (Var arg)
366 (vars, result) <- to_sum (tyConDataCons vect_tc)
369 $ mkWildCase scrut (mkTyConApp pdata_tc ty_args) res_ty
370 [(DataAlt pdata_dc, vars, mkCoerce co result)]
372 ty_args = mkTyVarTys $ tyConTyVars vect_tc
373 el_ty = mkTyConApp vect_tc ty_args
375 [pdata_dc] = tyConDataCons pdata_tc
378 pvoid <- builtin pvoidVar
379 return ([], Var pvoid)
380 to_sum [con] = to_prod con
382 (vars, exprs) <- mapAndUnzipM to_prod cons
383 (_, pdata_tc, sel_ty, arg_tys) <- reprSumTyCons vect_tc
384 sel <- newLocalVar (fsLit "sel") sel_ty
385 let [pdata_con] = tyConDataCons pdata_tc
386 result = wrapFamInstBody pdata_tc arg_tys
388 $ map Type arg_tys ++ (Var sel : exprs)
389 return (sel : concat vars, result)
393 pvoid <- builtin pvoidVar
394 return ([], Var pvoid)
396 var <- newLocalVar (fsLit "x") ty
397 return ([var], Var var)
400 vars <- newLocalVars (fsLit "x") tys
401 prod_tc <- builtin (prodTyCon (length tys))
402 (pdata_prod_tc, _) <- pdataReprTyCon (mkTyConApp prod_tc tys)
403 let [pdata_prod_con] = tyConDataCons pdata_prod_tc
404 result = wrapFamInstBody pdata_prod_tc tys
405 . mkConApp pdata_prod_con
406 $ map Type tys ++ map Var vars
407 return (vars, result)
409 tys = dataConRepArgTys con
411 buildFromArrPRepr :: TyCon -> TyCon -> TyCon -> VM CoreExpr
412 buildFromArrPRepr vect_tc prepr_tc pdata_tc
414 arg_ty <- mkPDataType =<< mkPReprType el_ty
415 res_ty <- mkPDataType el_ty
416 arg <- newLocalVar (fsLit "xs") arg_ty
418 pdata_co <- mkBuiltinCo pdataTyCon
419 let Just repr_co = tyConFamilyCoercion_maybe prepr_tc
420 co = mkAppCoercion pdata_co
421 $ mkTyConApp repr_co var_tys
423 scrut = mkCoerce co (Var arg)
425 (args, mk) <- from_sum res_ty scrut (tyConDataCons vect_tc)
427 let result = wrapFamInstBody pdata_tc var_tys
429 $ map Type var_tys ++ args
431 return $ Lam arg (mk result)
433 var_tys = mkTyVarTys $ tyConTyVars vect_tc
434 el_ty = mkTyConApp vect_tc var_tys
436 [pdata_dc] = tyConDataCons pdata_tc
438 from_sum res_ty expr [] = return ([], mk)
440 mk body = mkWildCase expr (exprType expr) res_ty [(DEFAULT, [], body)]
441 from_sum res_ty expr [con] = from_prod res_ty expr con
442 from_sum res_ty expr cons
444 (_, pdata_tc, sel_ty, arg_tys) <- reprSumTyCons vect_tc
445 sel <- newLocalVar (fsLit "sel") sel_ty
446 vars <- newLocalVars (fsLit "xs") arg_tys
447 rs <- zipWithM (from_prod res_ty) (map Var vars) cons
448 let (prods, mks) = unzip rs
449 [pdata_con] = tyConDataCons pdata_tc
450 scrut = unwrapFamInstScrut pdata_tc arg_tys expr
452 mk body = mkWildCase scrut (exprType scrut) res_ty
453 [(DataAlt pdata_con, sel : vars, foldr ($) body mks)]
454 return (Var sel : concat prods, mk)
457 from_prod res_ty expr con
458 | [] <- tys = return ([], id)
459 | [_] <- tys = return ([expr], id)
462 prod_tc <- builtin (prodTyCon (length tys))
463 (pdata_tc, _) <- pdataReprTyCon (mkTyConApp prod_tc tys)
464 pdata_tys <- mapM mkPDataType tys
465 vars <- newLocalVars (fsLit "ys") pdata_tys
466 let [pdata_con] = tyConDataCons pdata_tc
467 scrut = unwrapFamInstScrut pdata_tc tys expr
469 mk body = mkWildCase scrut (exprType scrut) res_ty
470 [(DataAlt pdata_con, vars, body)]
472 return (map Var vars, mk)
474 tys = dataConRepArgTys con
476 buildPRDict :: TyCon -> TyCon -> TyCon -> VM CoreExpr
477 buildPRDict vect_tc prepr_tc _
479 dict <- sum_dict (tyConDataCons vect_tc)
480 pr_co <- mkBuiltinCo prTyCon
481 let co = mkAppCoercion pr_co
483 $ mkTyConApp arg_co ty_args
484 return (mkCoerce co dict)
486 ty_args = mkTyVarTys (tyConTyVars vect_tc)
487 Just arg_co = tyConFamilyCoercion_maybe prepr_tc
489 sum_dict [] = prDFunOfTyCon =<< builtin voidTyCon
490 sum_dict [con] = prod_dict con
492 dicts <- mapM prod_dict cons
493 (sum_tc, _, _, sum_ty_args) <- reprSumTyCons vect_tc
494 dfun <- prDFunOfTyCon sum_tc
495 return $ dfun `mkTyApps` sum_ty_args `mkApps` dicts
498 | [] <- tys = prDFunOfTyCon =<< builtin voidTyCon
499 | [ty] <- tys = mkPR ty
501 dicts <- mapM mkPR tys
502 prod_tc <- builtin (prodTyCon (length tys))
503 dfun <- prDFunOfTyCon prod_tc
504 return $ dfun `mkTyApps` tys `mkApps` dicts
506 tys = dataConRepArgTys con
508 buildPDataTyCon :: TyCon -> TyCon -> VM TyCon
509 buildPDataTyCon orig_tc vect_tc = fixV $ \repr_tc ->
511 name' <- cloneName mkPDataTyConOcc orig_name
512 rhs <- buildPDataTyConRhs orig_name vect_tc repr_tc
513 pdata <- builtin pdataTyCon
515 liftDs $ buildAlgTyCon name'
517 [] -- no stupid theta
519 rec_flag -- FIXME: is this ok?
520 False -- FIXME: no generics
521 False -- not GADT syntax
522 (Just $ mk_fam_inst pdata vect_tc)
524 orig_name = tyConName orig_tc
525 tyvars = tyConTyVars vect_tc
526 rec_flag = boolToRecFlag (isRecursiveTyCon vect_tc)
529 buildPDataTyConRhs :: Name -> TyCon -> TyCon -> VM AlgTyConRhs
530 buildPDataTyConRhs orig_name vect_tc repr_tc
532 data_con <- buildPDataDataCon orig_name vect_tc repr_tc
533 return $ DataTyCon { data_cons = [data_con], is_enum = False }
535 buildPDataDataCon :: Name -> TyCon -> TyCon -> VM DataCon
536 buildPDataDataCon orig_name vect_tc repr_tc
538 dc_name <- cloneName mkPDataDataConOcc orig_name
539 comp_tys <- components
541 liftDs $ buildDataCon dc_name
543 (map (const NotMarkedStrict) comp_tys)
544 [] -- no field labels
546 [] -- no existentials
550 (mkFamilyTyConApp repr_tc (mkTyVarTys tvs))
553 tvs = tyConTyVars vect_tc
554 cons = tyConDataCons vect_tc
558 | arity > 1 = liftM2 (:) (builtin (selTy arity)) data_components
559 | otherwise = data_components
561 data_components = mapM mkPDataType
563 $ map dataConRepArgTys cons
565 mkPADFun :: TyCon -> VM Var
567 = newExportedVar (mkPADFunOcc $ getOccName vect_tc) =<< paDFunType vect_tc
569 buildTyConBindings :: TyCon -> TyCon -> TyCon -> TyCon -> Var
570 -> VM [(Var, CoreExpr)]
571 buildTyConBindings orig_tc vect_tc prepr_tc pdata_tc dfun
573 vectDataConWorkers orig_tc vect_tc pdata_tc
574 dict <- buildPADict vect_tc prepr_tc pdata_tc dfun
576 return $ (dfun, dict) : binds
578 vectDataConWorkers :: TyCon -> TyCon -> TyCon -> VM ()
579 vectDataConWorkers orig_tc vect_tc arr_tc
582 . zipWith3 def_worker (tyConDataCons orig_tc) rep_tys
583 $ zipWith4 mk_data_con (tyConDataCons vect_tc)
586 (tail $ tails rep_tys)
587 mapM_ (uncurry hoistBinding) bs
589 tyvars = tyConTyVars vect_tc
590 var_tys = mkTyVarTys tyvars
591 ty_args = map Type var_tys
592 res_ty = mkTyConApp vect_tc var_tys
594 cons = tyConDataCons vect_tc
596 [arr_dc] = tyConDataCons arr_tc
598 rep_tys = map dataConRepArgTys $ tyConDataCons vect_tc
601 mk_data_con con tys pre post
602 = liftM2 (,) (vect_data_con con)
603 (lift_data_con tys pre post (mkDataConTag con))
605 sel_replicate len tag
607 rep <- builtin (selReplicate arity)
608 return [rep `mkApps` [len, tag]]
610 | otherwise = return []
612 vect_data_con con = return $ mkConApp con ty_args
613 lift_data_con tys pre_tys post_tys tag
615 len <- builtin liftingContext
616 args <- mapM (newLocalVar (fsLit "xs"))
617 =<< mapM mkPDataType tys
619 sel <- sel_replicate (Var len) tag
621 pre <- mapM emptyPD (concat pre_tys)
622 post <- mapM emptyPD (concat post_tys)
624 return . mkLams (len : args)
625 . wrapFamInstBody arr_tc var_tys
627 $ ty_args ++ sel ++ pre ++ map Var args ++ post
629 def_worker data_con arg_tys mk_body
633 . polyAbstract tyvars $ \abstract ->
634 liftM (abstract . vectorised)
635 $ buildClosures tyvars [] arg_tys res_ty mk_body
637 vect_worker <- cloneId mkVectOcc orig_worker (exprType body)
638 defGlobalVar orig_worker vect_worker
639 return (vect_worker, body)
641 orig_worker = dataConWorkId data_con
643 buildPADict :: TyCon -> TyCon -> TyCon -> Var -> VM CoreExpr
644 buildPADict vect_tc prepr_tc arr_tc _
645 = polyAbstract tvs $ \abstract ->
647 meth_binds <- mapM mk_method paMethods
648 let meth_exprs = map (Var . fst) meth_binds
650 pa_dc <- builtin paDataCon
651 let dict = mkConApp pa_dc (Type (mkTyConApp vect_tc arg_tys) : meth_exprs)
652 body = Let (Rec meth_binds) dict
653 return . mkInlineMe $ abstract body
655 tvs = tyConTyVars arr_tc
656 arg_tys = mkTyVarTys tvs
658 mk_method (name, build)
661 body <- build vect_tc prepr_tc arr_tc
662 var <- newLocalVar name (exprType body)
663 return (var, mkInlineMe body)
665 paMethods :: [(FastString, TyCon -> TyCon -> TyCon -> VM CoreExpr)]
666 paMethods = [(fsLit "toPRepr", buildToPRepr),
667 (fsLit "fromPRepr", buildFromPRepr),
668 (fsLit "toArrPRepr", buildToArrPRepr),
669 (fsLit "fromArrPRepr", buildFromArrPRepr),
670 (fsLit "dictPRepr", buildPRDict)]
672 -- | Split the given tycons into two sets depending on whether they have to be
673 -- converted (first list) or not (second list). The first argument contains
674 -- information about the conversion status of external tycons:
676 -- * tycons which have converted versions are mapped to True
677 -- * tycons which are not changed by vectorisation are mapped to False
678 -- * tycons which can't be converted are not elements of the map
680 classifyTyCons :: UniqFM Bool -> [TyConGroup] -> ([TyCon], [TyCon])
681 classifyTyCons = classify [] []
683 classify conv keep _ [] = (conv, keep)
684 classify conv keep cs ((tcs, ds) : rs)
685 | can_convert && must_convert
686 = classify (tcs ++ conv) keep (cs `addListToUFM` [(tc,True) | tc <- tcs]) rs
688 = classify conv (tcs ++ keep) (cs `addListToUFM` [(tc,False) | tc <- tcs]) rs
690 = classify conv keep cs rs
692 refs = ds `delListFromUniqSet` tcs
694 can_convert = isNullUFM (refs `minusUFM` cs) && all convertable tcs
695 must_convert = foldUFM (||) False (intersectUFM_C const cs refs)
697 convertable tc = isDataTyCon tc && all isVanillaDataCon (tyConDataCons tc)
699 -- | Compute mutually recursive groups of tycons in topological order
701 tyConGroups :: [TyCon] -> [TyConGroup]
702 tyConGroups tcs = map mk_grp (stronglyConnCompFromEdgedVertices edges)
704 edges = [((tc, ds), tc, uniqSetToList ds) | tc <- tcs
705 , let ds = tyConsOfTyCon tc]
707 mk_grp (AcyclicSCC (tc, ds)) = ([tc], ds)
708 mk_grp (CyclicSCC els) = (tcs, unionManyUniqSets dss)
710 (tcs, dss) = unzip els
712 tyConsOfTyCon :: TyCon -> UniqSet TyCon
714 = tyConsOfTypes . concatMap dataConRepArgTys . tyConDataCons
716 tyConsOfType :: Type -> UniqSet TyCon
718 | Just ty' <- coreView ty = tyConsOfType ty'
719 tyConsOfType (TyVarTy _) = emptyUniqSet
720 tyConsOfType (TyConApp tc tys) = extend (tyConsOfTypes tys)
722 extend | isUnLiftedTyCon tc
723 || isTupleTyCon tc = id
725 | otherwise = (`addOneToUniqSet` tc)
727 tyConsOfType (AppTy a b) = tyConsOfType a `unionUniqSets` tyConsOfType b
728 tyConsOfType (FunTy a b) = (tyConsOfType a `unionUniqSets` tyConsOfType b)
729 `addOneToUniqSet` funTyCon
730 tyConsOfType (ForAllTy _ ty) = tyConsOfType ty
731 tyConsOfType other = pprPanic "ClosureConv.tyConsOfType" $ ppr other
733 tyConsOfTypes :: [Type] -> UniqSet TyCon
734 tyConsOfTypes = unionManyUniqSets . map tyConsOfType
737 -- ----------------------------------------------------------------------------
740 fromVect :: Type -> CoreExpr -> VM CoreExpr
741 fromVect ty expr | Just ty' <- coreView ty = fromVect ty' expr
742 fromVect (FunTy arg_ty res_ty) expr
744 arg <- newLocalVar (fsLit "x") arg_ty
745 varg <- toVect arg_ty (Var arg)
746 varg_ty <- vectType arg_ty
747 vres_ty <- vectType res_ty
748 apply <- builtin applyVar
749 body <- fromVect res_ty
750 $ Var apply `mkTyApps` [varg_ty, vres_ty] `mkApps` [expr, varg]
751 return $ Lam arg body
753 = identityConv ty >> return expr
755 toVect :: Type -> CoreExpr -> VM CoreExpr
756 toVect ty expr = identityConv ty >> return expr
758 identityConv :: Type -> VM ()
759 identityConv ty | Just ty' <- coreView ty = identityConv ty'
760 identityConv (TyConApp tycon tys)
762 mapM_ identityConv tys
763 identityConvTyCon tycon
766 identityConvTyCon :: TyCon -> VM ()
768 | isBoxedTupleTyCon tc = return ()
769 | isUnLiftedTyCon tc = return ()
771 tc' <- maybeV (lookupTyCon tc)
772 if tc == tc' then return () else noV