1 {-# OPTIONS -fno-warn-missing-signatures #-}
3 module VectType ( vectTyCon, vectAndLiftType, vectType, vectTypeEnv,
4 -- arrSumArity, pdataCompTys, pdataCompVars,
11 import Vectorise.Convert
13 import Vectorise.Monad
14 import Vectorise.Builtins
15 import Vectorise.Type.Type
16 import Vectorise.Type.TyConDecl
17 import Vectorise.Type.Classify
18 import Vectorise.Utils.Closure
19 import Vectorise.Utils.Hoisting
21 import HscTypes ( TypeEnv, extendTypeEnvList, typeEnvTyCons )
26 import MkCore ( mkWildCase )
32 import FamInstEnv ( FamInst, mkLocalFamInst )
37 import Name ( Name, getOccName )
47 import MonadUtils ( zipWith3M, foldrM, concatMapM )
48 import Control.Monad ( liftM, liftM2, zipWithM, zipWithM_, mapAndUnzipM )
52 dtrace s x = if debug then pprTrace "VectType" s x else x
55 -- | Vectorise a type environment.
56 -- The type environment contains all the type things defined in a module.
59 -> VM ( TypeEnv -- Vectorised type environment.
60 , [FamInst] -- New type family instances.
61 , [(Var, CoreExpr)]) -- New top level bindings.
66 cs <- readGEnv $ mk_map . global_tycons
68 -- Split the list of TyCons into the ones we have to vectorise vs the
69 -- ones we can pass through unchanged. We also pass through algebraic
70 -- types that use non Haskell98 features, as we don't handle those.
71 let (conv_tcs, keep_tcs) = classifyTyCons cs groups
72 keep_dcs = concatMap tyConDataCons keep_tcs
74 zipWithM_ defTyCon keep_tcs keep_tcs
75 zipWithM_ defDataCon keep_dcs keep_dcs
77 new_tcs <- vectTyConDecls conv_tcs
79 let orig_tcs = keep_tcs ++ conv_tcs
81 -- We don't need to make new representation types for dictionary
82 -- constructors. The constructors are always fully applied, and we don't
83 -- need to lift them to arrays as a dictionary of a particular type
84 -- always has the same value.
85 let vect_tcs = filter (not . isClassTyCon)
88 (_, binds, inst_tcs) <- fixV $ \ ~(dfuns', _, _) ->
90 defTyConPAs (zipLazy vect_tcs dfuns')
91 reprs <- mapM tyConRepr vect_tcs
92 repr_tcs <- zipWith3M buildPReprTyCon orig_tcs vect_tcs reprs
93 pdata_tcs <- zipWith3M buildPDataTyCon orig_tcs vect_tcs reprs
96 $ zipWith5 buildTyConBindings
104 return (dfuns, binds, repr_tcs ++ pdata_tcs)
106 let all_new_tcs = new_tcs ++ inst_tcs
108 let new_env = extendTypeEnvList env
109 (map ATyCon all_new_tcs
110 ++ [ADataCon dc | tc <- all_new_tcs
111 , dc <- tyConDataCons tc])
113 return (new_env, map mkLocalFamInst inst_tcs, binds)
115 tycons = typeEnvTyCons env
116 groups = tyConGroups tycons
118 mk_map env = listToUFM_Directly [(u, getUnique n /= u) | (u,n) <- nameEnvUniqueElts env]
121 mk_fam_inst :: TyCon -> TyCon -> (TyCon, [Type])
122 mk_fam_inst fam_tc arg_tc
123 = (fam_tc, [mkTyConApp arg_tc . mkTyVarTys $ tyConTyVars arg_tc])
126 buildPReprTyCon :: TyCon -> TyCon -> SumRepr -> VM TyCon
127 buildPReprTyCon orig_tc vect_tc repr
129 name <- cloneName mkPReprTyConOcc (tyConName orig_tc)
130 -- rhs_ty <- buildPReprType vect_tc
131 rhs_ty <- sumReprType repr
132 prepr_tc <- builtin preprTyCon
133 liftDs $ buildSynTyCon name
135 (SynonymTyCon rhs_ty)
137 (Just $ mk_fam_inst prepr_tc vect_tc)
139 tyvars = tyConTyVars vect_tc
141 data CompRepr = Keep Type
142 CoreExpr -- PR dictionary for the type
145 data ProdRepr = EmptyProd
147 | Prod { repr_tup_tc :: TyCon -- representation tuple tycon
148 , repr_ptup_tc :: TyCon -- PData representation tycon
149 , repr_comp_tys :: [Type] -- representation types of
150 , repr_comps :: [CompRepr] -- components
152 data ConRepr = ConRepr DataCon ProdRepr
154 data SumRepr = EmptySum
156 | Sum { repr_sum_tc :: TyCon -- representation sum tycon
157 , repr_psum_tc :: TyCon -- PData representation tycon
158 , repr_sel_ty :: Type -- type of selector
159 , repr_con_tys :: [Type] -- representation types of
160 , repr_cons :: [ConRepr] -- components
163 tyConRepr :: TyCon -> VM SumRepr
164 tyConRepr tc = sum_repr (tyConDataCons tc)
166 sum_repr [] = return EmptySum
167 sum_repr [con] = liftM UnarySum (con_repr con)
169 rs <- mapM con_repr cons
170 sum_tc <- builtin (sumTyCon arity)
171 tys <- mapM conReprType rs
172 (psum_tc, _) <- pdataReprTyCon (mkTyConApp sum_tc tys)
173 sel_ty <- builtin (selTy arity)
174 return $ Sum { repr_sum_tc = sum_tc
175 , repr_psum_tc = psum_tc
176 , repr_sel_ty = sel_ty
183 con_repr con = liftM (ConRepr con) (prod_repr (dataConRepArgTys con))
185 prod_repr [] = return EmptyProd
186 prod_repr [ty] = liftM UnaryProd (comp_repr ty)
188 rs <- mapM comp_repr tys
189 tup_tc <- builtin (prodTyCon arity)
190 tys' <- mapM compReprType rs
191 (ptup_tc, _) <- pdataReprTyCon (mkTyConApp tup_tc tys')
192 return $ Prod { repr_tup_tc = tup_tc
193 , repr_ptup_tc = ptup_tc
194 , repr_comp_tys = tys'
200 comp_repr ty = liftM (Keep ty) (prDictOfType ty)
201 `orElseV` return (Wrap ty)
203 sumReprType :: SumRepr -> VM Type
204 sumReprType EmptySum = voidType
205 sumReprType (UnarySum r) = conReprType r
206 sumReprType (Sum { repr_sum_tc = sum_tc, repr_con_tys = tys })
207 = return $ mkTyConApp sum_tc tys
209 conReprType :: ConRepr -> VM Type
210 conReprType (ConRepr _ r) = prodReprType r
212 prodReprType :: ProdRepr -> VM Type
213 prodReprType EmptyProd = voidType
214 prodReprType (UnaryProd r) = compReprType r
215 prodReprType (Prod { repr_tup_tc = tup_tc, repr_comp_tys = tys })
216 = return $ mkTyConApp tup_tc tys
218 compReprType :: CompRepr -> VM Type
219 compReprType (Keep ty _) = return ty
220 compReprType (Wrap ty) = do
221 wrap_tc <- builtin wrapTyCon
222 return $ mkTyConApp wrap_tc [ty]
224 compOrigType :: CompRepr -> Type
225 compOrigType (Keep ty _) = ty
226 compOrigType (Wrap ty) = ty
228 buildToPRepr :: TyCon -> TyCon -> TyCon -> SumRepr -> VM CoreExpr
229 buildToPRepr vect_tc repr_tc _ repr
231 let arg_ty = mkTyConApp vect_tc ty_args
232 res_ty <- mkPReprType arg_ty
233 arg <- newLocalVar (fsLit "x") arg_ty
234 result <- to_sum (Var arg) arg_ty res_ty repr
235 return $ Lam arg result
237 ty_args = mkTyVarTys (tyConTyVars vect_tc)
239 wrap_repr_inst = wrapFamInstBody repr_tc ty_args
241 to_sum _ _ _ EmptySum
243 void <- builtin voidVar
244 return $ wrap_repr_inst $ Var void
246 to_sum arg arg_ty res_ty (UnarySum r)
248 (pat, vars, body) <- con_alt r
249 return $ mkWildCase arg arg_ty res_ty
250 [(pat, vars, wrap_repr_inst body)]
252 to_sum arg arg_ty res_ty (Sum { repr_sum_tc = sum_tc
254 , repr_cons = cons })
256 alts <- mapM con_alt cons
257 let alts' = [(pat, vars, wrap_repr_inst
258 $ mkConApp sum_con (map Type tys ++ [body]))
259 | ((pat, vars, body), sum_con)
260 <- zip alts (tyConDataCons sum_tc)]
261 return $ mkWildCase arg arg_ty res_ty alts'
263 con_alt (ConRepr con r)
265 (vars, body) <- to_prod r
266 return (DataAlt con, vars, body)
270 void <- builtin voidVar
271 return ([], Var void)
273 to_prod (UnaryProd comp)
275 var <- newLocalVar (fsLit "x") (compOrigType comp)
276 body <- to_comp (Var var) comp
279 to_prod(Prod { repr_tup_tc = tup_tc
280 , repr_comp_tys = tys
281 , repr_comps = comps })
283 vars <- newLocalVars (fsLit "x") (map compOrigType comps)
284 exprs <- zipWithM to_comp (map Var vars) comps
285 return (vars, mkConApp tup_con (map Type tys ++ exprs))
287 [tup_con] = tyConDataCons tup_tc
289 to_comp expr (Keep _ _) = return expr
290 to_comp expr (Wrap ty) = do
291 wrap_tc <- builtin wrapTyCon
292 return $ wrapNewTypeBody wrap_tc [ty] expr
295 buildFromPRepr :: TyCon -> TyCon -> TyCon -> SumRepr -> VM CoreExpr
296 buildFromPRepr vect_tc repr_tc _ repr
298 arg_ty <- mkPReprType res_ty
299 arg <- newLocalVar (fsLit "x") arg_ty
301 result <- from_sum (unwrapFamInstScrut repr_tc ty_args (Var arg))
303 return $ Lam arg result
305 ty_args = mkTyVarTys (tyConTyVars vect_tc)
306 res_ty = mkTyConApp vect_tc ty_args
310 dummy <- builtin fromVoidVar
311 return $ Var dummy `App` Type res_ty
313 from_sum expr (UnarySum r) = from_con expr r
314 from_sum expr (Sum { repr_sum_tc = sum_tc
316 , repr_cons = cons })
318 vars <- newLocalVars (fsLit "x") tys
319 es <- zipWithM from_con (map Var vars) cons
320 return $ mkWildCase expr (exprType expr) res_ty
321 [(DataAlt con, [var], e)
322 | (con, var, e) <- zip3 (tyConDataCons sum_tc) vars es]
324 from_con expr (ConRepr con r)
325 = from_prod expr (mkConApp con $ map Type ty_args) r
327 from_prod _ con EmptyProd = return con
328 from_prod expr con (UnaryProd r)
330 e <- from_comp expr r
333 from_prod expr con (Prod { repr_tup_tc = tup_tc
334 , repr_comp_tys = tys
338 vars <- newLocalVars (fsLit "y") tys
339 es <- zipWithM from_comp (map Var vars) comps
340 return $ mkWildCase expr (exprType expr) res_ty
341 [(DataAlt tup_con, vars, con `mkApps` es)]
343 [tup_con] = tyConDataCons tup_tc
345 from_comp expr (Keep _ _) = return expr
346 from_comp expr (Wrap ty)
348 wrap <- builtin wrapTyCon
349 return $ unwrapNewTypeBody wrap [ty] expr
352 buildToArrPRepr :: TyCon -> TyCon -> TyCon -> SumRepr -> VM CoreExpr
353 buildToArrPRepr vect_tc prepr_tc pdata_tc r
355 arg_ty <- mkPDataType el_ty
356 res_ty <- mkPDataType =<< mkPReprType el_ty
357 arg <- newLocalVar (fsLit "xs") arg_ty
359 pdata_co <- mkBuiltinCo pdataTyCon
360 let Just repr_co = tyConFamilyCoercion_maybe prepr_tc
361 co = mkAppCoercion pdata_co
363 $ mkTyConApp repr_co ty_args
365 scrut = unwrapFamInstScrut pdata_tc ty_args (Var arg)
367 (vars, result) <- to_sum r
370 $ mkWildCase scrut (mkTyConApp pdata_tc ty_args) res_ty
371 [(DataAlt pdata_dc, vars, mkCoerce co result)]
373 ty_args = mkTyVarTys $ tyConTyVars vect_tc
374 el_ty = mkTyConApp vect_tc ty_args
376 [pdata_dc] = tyConDataCons pdata_tc
380 pvoid <- builtin pvoidVar
381 return ([], Var pvoid)
382 to_sum (UnarySum r) = to_con r
383 to_sum (Sum { repr_psum_tc = psum_tc
384 , repr_sel_ty = sel_ty
389 (vars, exprs) <- mapAndUnzipM to_con cons
390 sel <- newLocalVar (fsLit "sel") sel_ty
391 return (sel : concat vars, mk_result (Var sel) exprs)
393 [psum_con] = tyConDataCons psum_tc
394 mk_result sel exprs = wrapFamInstBody psum_tc tys
396 $ map Type tys ++ (sel : exprs)
398 to_con (ConRepr _ r) = to_prod r
400 to_prod EmptyProd = do
401 pvoid <- builtin pvoidVar
402 return ([], Var pvoid)
403 to_prod (UnaryProd r)
405 pty <- mkPDataType (compOrigType r)
406 var <- newLocalVar (fsLit "x") pty
407 expr <- to_comp (Var var) r
410 to_prod (Prod { repr_ptup_tc = ptup_tc
411 , repr_comp_tys = tys
412 , repr_comps = comps })
414 ptys <- mapM (mkPDataType . compOrigType) comps
415 vars <- newLocalVars (fsLit "x") ptys
416 es <- zipWithM to_comp (map Var vars) comps
417 return (vars, mk_result es)
419 [ptup_con] = tyConDataCons ptup_tc
420 mk_result exprs = wrapFamInstBody ptup_tc tys
422 $ map Type tys ++ exprs
424 to_comp expr (Keep _ _) = return expr
426 -- FIXME: this is bound to be wrong!
427 to_comp expr (Wrap ty)
429 wrap_tc <- builtin wrapTyCon
430 (pwrap_tc, _) <- pdataReprTyCon (mkTyConApp wrap_tc [ty])
431 return $ wrapNewTypeBody pwrap_tc [ty] expr
434 buildFromArrPRepr :: TyCon -> TyCon -> TyCon -> SumRepr -> VM CoreExpr
435 buildFromArrPRepr vect_tc prepr_tc pdata_tc r
437 arg_ty <- mkPDataType =<< mkPReprType el_ty
438 res_ty <- mkPDataType el_ty
439 arg <- newLocalVar (fsLit "xs") arg_ty
441 pdata_co <- mkBuiltinCo pdataTyCon
442 let Just repr_co = tyConFamilyCoercion_maybe prepr_tc
443 co = mkAppCoercion pdata_co
444 $ mkTyConApp repr_co var_tys
446 scrut = mkCoerce co (Var arg)
448 mk_result args = wrapFamInstBody pdata_tc var_tys
450 $ map Type var_tys ++ args
452 (expr, _) <- fixV $ \ ~(_, args) ->
453 from_sum res_ty (mk_result args) scrut r
455 return $ Lam arg expr
457 -- (args, mk) <- from_sum res_ty scrut r
459 -- let result = wrapFamInstBody pdata_tc var_tys
460 -- . mkConApp pdata_dc
461 -- $ map Type var_tys ++ args
463 -- return $ Lam arg (mk result)
465 var_tys = mkTyVarTys $ tyConTyVars vect_tc
466 el_ty = mkTyConApp vect_tc var_tys
468 [pdata_con] = tyConDataCons pdata_tc
470 from_sum _ res _ EmptySum = return (res, [])
471 from_sum res_ty res expr (UnarySum r) = from_con res_ty res expr r
472 from_sum res_ty res expr (Sum { repr_psum_tc = psum_tc
473 , repr_sel_ty = sel_ty
475 , repr_cons = cons })
477 sel <- newLocalVar (fsLit "sel") sel_ty
478 ptys <- mapM mkPDataType tys
479 vars <- newLocalVars (fsLit "xs") ptys
480 (res', args) <- fold from_con res_ty res (map Var vars) cons
481 let scrut = unwrapFamInstScrut psum_tc tys expr
482 body = mkWildCase scrut (exprType scrut) res_ty
483 [(DataAlt psum_con, sel : vars, res')]
484 return (body, Var sel : args)
486 [psum_con] = tyConDataCons psum_tc
489 from_con res_ty res expr (ConRepr _ r) = from_prod res_ty res expr r
491 from_prod _ res _ EmptyProd = return (res, [])
492 from_prod res_ty res expr (UnaryProd r)
493 = from_comp res_ty res expr r
494 from_prod res_ty res expr (Prod { repr_ptup_tc = ptup_tc
495 , repr_comp_tys = tys
496 , repr_comps = comps })
498 ptys <- mapM mkPDataType tys
499 vars <- newLocalVars (fsLit "ys") ptys
500 (res', args) <- fold from_comp res_ty res (map Var vars) comps
501 let scrut = unwrapFamInstScrut ptup_tc tys expr
502 body = mkWildCase scrut (exprType scrut) res_ty
503 [(DataAlt ptup_con, vars, res')]
506 [ptup_con] = tyConDataCons ptup_tc
508 from_comp _ res expr (Keep _ _) = return (res, [expr])
509 from_comp _ res expr (Wrap ty)
511 wrap_tc <- builtin wrapTyCon
512 (pwrap_tc, _) <- pdataReprTyCon (mkTyConApp wrap_tc [ty])
513 return (res, [unwrapNewTypeBody pwrap_tc [ty]
514 $ unwrapFamInstScrut pwrap_tc [ty] expr])
516 fold f res_ty res exprs rs = foldrM f' (res, []) (zip exprs rs)
518 f' (expr, r) (res, args) = do
519 (res', args') <- f res_ty res expr r
520 return (res', args' ++ args)
522 buildPRDict :: TyCon -> TyCon -> TyCon -> SumRepr -> VM CoreExpr
523 buildPRDict vect_tc prepr_tc _ r
526 pr_co <- mkBuiltinCo prTyCon
527 let co = mkAppCoercion pr_co
529 $ mkTyConApp arg_co ty_args
530 return (mkCoerce co dict)
532 ty_args = mkTyVarTys (tyConTyVars vect_tc)
533 Just arg_co = tyConFamilyCoercion_maybe prepr_tc
535 sum_dict EmptySum = prDFunOfTyCon =<< builtin voidTyCon
536 sum_dict (UnarySum r) = con_dict r
537 sum_dict (Sum { repr_sum_tc = sum_tc
542 dicts <- mapM con_dict cons
543 dfun <- prDFunOfTyCon sum_tc
544 return $ dfun `mkTyApps` tys `mkApps` dicts
546 con_dict (ConRepr _ r) = prod_dict r
548 prod_dict EmptyProd = prDFunOfTyCon =<< builtin voidTyCon
549 prod_dict (UnaryProd r) = comp_dict r
550 prod_dict (Prod { repr_tup_tc = tup_tc
551 , repr_comp_tys = tys
552 , repr_comps = comps })
554 dicts <- mapM comp_dict comps
555 dfun <- prDFunOfTyCon tup_tc
556 return $ dfun `mkTyApps` tys `mkApps` dicts
558 comp_dict (Keep _ pr) = return pr
559 comp_dict (Wrap ty) = wrapPR ty
562 buildPDataTyCon :: TyCon -> TyCon -> SumRepr -> VM TyCon
563 buildPDataTyCon orig_tc vect_tc repr = fixV $ \repr_tc ->
565 name' <- cloneName mkPDataTyConOcc orig_name
566 rhs <- buildPDataTyConRhs orig_name vect_tc repr_tc repr
567 pdata <- builtin pdataTyCon
569 liftDs $ buildAlgTyCon name'
571 [] -- no stupid theta
573 rec_flag -- FIXME: is this ok?
574 False -- FIXME: no generics
575 False -- not GADT syntax
576 (Just $ mk_fam_inst pdata vect_tc)
578 orig_name = tyConName orig_tc
579 tyvars = tyConTyVars vect_tc
580 rec_flag = boolToRecFlag (isRecursiveTyCon vect_tc)
583 buildPDataTyConRhs :: Name -> TyCon -> TyCon -> SumRepr -> VM AlgTyConRhs
584 buildPDataTyConRhs orig_name vect_tc repr_tc repr
586 data_con <- buildPDataDataCon orig_name vect_tc repr_tc repr
587 return $ DataTyCon { data_cons = [data_con], is_enum = False }
589 buildPDataDataCon :: Name -> TyCon -> TyCon -> SumRepr -> VM DataCon
590 buildPDataDataCon orig_name vect_tc repr_tc repr
592 dc_name <- cloneName mkPDataDataConOcc orig_name
593 comp_tys <- sum_tys repr
595 liftDs $ buildDataCon dc_name
597 (map (const HsNoBang) comp_tys)
598 [] -- no field labels
600 [] -- no existentials
604 (mkFamilyTyConApp repr_tc (mkTyVarTys tvs))
607 tvs = tyConTyVars vect_tc
609 sum_tys EmptySum = return []
610 sum_tys (UnarySum r) = con_tys r
611 sum_tys (Sum { repr_sel_ty = sel_ty
612 , repr_cons = cons })
613 = liftM (sel_ty :) (concatMapM con_tys cons)
615 con_tys (ConRepr _ r) = prod_tys r
617 prod_tys EmptyProd = return []
618 prod_tys (UnaryProd r) = liftM singleton (comp_ty r)
619 prod_tys (Prod { repr_comps = comps }) = mapM comp_ty comps
621 comp_ty r = mkPDataType (compOrigType r)
624 buildTyConBindings :: TyCon -> TyCon -> TyCon -> TyCon -> SumRepr
626 buildTyConBindings orig_tc vect_tc prepr_tc pdata_tc repr
628 vectDataConWorkers orig_tc vect_tc pdata_tc
629 buildPADict vect_tc prepr_tc pdata_tc repr
631 vectDataConWorkers :: TyCon -> TyCon -> TyCon -> VM ()
632 vectDataConWorkers orig_tc vect_tc arr_tc
635 . zipWith3 def_worker (tyConDataCons orig_tc) rep_tys
636 $ zipWith4 mk_data_con (tyConDataCons vect_tc)
639 (tail $ tails rep_tys)
640 mapM_ (uncurry hoistBinding) bs
642 tyvars = tyConTyVars vect_tc
643 var_tys = mkTyVarTys tyvars
644 ty_args = map Type var_tys
645 res_ty = mkTyConApp vect_tc var_tys
647 cons = tyConDataCons vect_tc
649 [arr_dc] = tyConDataCons arr_tc
651 rep_tys = map dataConRepArgTys $ tyConDataCons vect_tc
654 mk_data_con con tys pre post
655 = liftM2 (,) (vect_data_con con)
656 (lift_data_con tys pre post (mkDataConTag con))
658 sel_replicate len tag
660 rep <- builtin (selReplicate arity)
661 return [rep `mkApps` [len, tag]]
663 | otherwise = return []
665 vect_data_con con = return $ mkConApp con ty_args
666 lift_data_con tys pre_tys post_tys tag
668 len <- builtin liftingContext
669 args <- mapM (newLocalVar (fsLit "xs"))
670 =<< mapM mkPDataType tys
672 sel <- sel_replicate (Var len) tag
674 pre <- mapM emptyPD (concat pre_tys)
675 post <- mapM emptyPD (concat post_tys)
677 return . mkLams (len : args)
678 . wrapFamInstBody arr_tc var_tys
680 $ ty_args ++ sel ++ pre ++ map Var args ++ post
682 def_worker data_con arg_tys mk_body
684 arity <- polyArity tyvars
687 . polyAbstract tyvars $ \args ->
688 liftM (mkLams (tyvars ++ args) . vectorised)
689 $ buildClosures tyvars [] arg_tys res_ty mk_body
691 raw_worker <- cloneId mkVectOcc orig_worker (exprType body)
692 let vect_worker = raw_worker `setIdUnfolding`
693 mkInlineRule body (Just arity)
694 defGlobalVar orig_worker vect_worker
695 return (vect_worker, body)
697 orig_worker = dataConWorkId data_con
699 buildPADict :: TyCon -> TyCon -> TyCon -> SumRepr -> VM Var
700 buildPADict vect_tc prepr_tc arr_tc repr
701 = polyAbstract tvs $ \args ->
703 method_ids <- mapM (method args) paMethods
705 pa_tc <- builtin paTyCon
706 pa_dc <- builtin paDataCon
707 let dict = mkLams (tvs ++ args)
709 $ Type inst_ty : map (method_call args) method_ids
711 dfun_ty = mkForAllTys tvs
712 $ mkFunTys (map varType args) (mkTyConApp pa_tc [inst_ty])
714 raw_dfun <- newExportedVar dfun_name dfun_ty
715 let dfun = raw_dfun `setIdUnfolding` mkDFunUnfolding dfun_ty (map Var method_ids)
716 `setInlinePragma` dfunInlinePragma
718 hoistBinding dfun dict
721 tvs = tyConTyVars vect_tc
722 arg_tys = mkTyVarTys tvs
723 inst_ty = mkTyConApp vect_tc arg_tys
725 dfun_name = mkPADFunOcc (getOccName vect_tc)
727 method args (name, build)
730 expr <- build vect_tc prepr_tc arr_tc repr
731 let body = mkLams (tvs ++ args) expr
732 raw_var <- newExportedVar (method_name name) (exprType body)
734 `setIdUnfolding` mkInlineRule body (Just (length args))
735 `setInlinePragma` alwaysInlinePragma
736 hoistBinding var body
739 method_call args id = mkApps (Var id) (map Type arg_tys ++ map Var args)
741 method_name name = mkVarOcc $ occNameString dfun_name ++ ('$' : name)
744 paMethods :: [(String, TyCon -> TyCon -> TyCon -> SumRepr -> VM CoreExpr)]
745 paMethods = [("dictPRepr", buildPRDict),
746 ("toPRepr", buildToPRepr),
747 ("fromPRepr", buildFromPRepr),
748 ("toArrPRepr", buildToArrPRepr),
749 ("fromArrPRepr", buildFromArrPRepr)]