VECTORISE pragmas for type classes and instances
[ghc.git] / compiler / vectorise / Vectorise / Utils / Base.hs
1 module Vectorise.Utils.Base (
2 voidType,
3 newLocalVVar,
4
5 mkDataConTagLit,
6 mkDataConTag, dataConTagZ,
7 mkBuiltinTyConApp,
8 mkBuiltinTyConApps,
9 mkWrapType,
10 mkClosureTypes,
11 mkPReprType,
12 mkPArrayType, splitPrimTyCon,
13 mkPArray,
14 mkPDataType,
15 mkBuiltinCo,
16 mkVScrut,
17
18 -- preprSynTyCon,
19 pdataReprTyCon,
20 pdataReprDataCon,
21 prDFunOfTyCon
22 ) where
23
24 import Vectorise.Monad
25 import Vectorise.Vect
26 import Vectorise.Builtins
27
28 import CoreSyn
29 import CoreUtils
30 import Coercion
31 import Type
32 import TyCon
33 import DataCon
34 import MkId
35 import Literal
36 import Outputable
37 import FastString
38
39 import Control.Monad (liftM)
40
41
42 -- Simple Types ---------------------------------------------------------------
43 voidType :: VM Type
44 voidType = mkBuiltinTyConApp voidTyCon []
45
46
47 -- Name Generation ------------------------------------------------------------
48 newLocalVVar :: FastString -> Type -> VM VVar
49 newLocalVVar fs vty
50 = do
51 lty <- mkPDataType vty
52 vv <- newLocalVar fs vty
53 lv <- newLocalVar fs lty
54 return (vv,lv)
55
56
57 -- Constructors ---------------------------------------------------------------
58 mkDataConTagLit :: DataCon -> Literal
59 mkDataConTagLit = mkMachInt . toInteger . dataConTagZ
60
61
62 mkDataConTag :: DataCon -> CoreExpr
63 mkDataConTag = mkIntLitInt . dataConTagZ
64
65
66 dataConTagZ :: DataCon -> Int
67 dataConTagZ con = dataConTag con - fIRST_TAG
68
69
70 mkBuiltinTyConApp :: (Builtins -> TyCon) -> [Type] -> VM Type
71 mkBuiltinTyConApp get_tc tys
72 = do
73 tc <- builtin get_tc
74 return $ mkTyConApp tc tys
75
76
77 mkBuiltinTyConApps :: (Builtins -> TyCon) -> [Type] -> Type -> VM Type
78 mkBuiltinTyConApps get_tc tys ty
79 = do
80 tc <- builtin get_tc
81 return $ foldr (mk tc) ty tys
82 where
83 mk tc ty1 ty2 = mkTyConApp tc [ty1,ty2]
84
85
86 mkWrapType :: Type -> VM Type
87 mkWrapType ty = mkBuiltinTyConApp wrapTyCon [ty]
88
89
90 mkClosureTypes :: [Type] -> Type -> VM Type
91 mkClosureTypes = mkBuiltinTyConApps closureTyCon
92
93
94 mkPReprType :: Type -> VM Type
95 mkPReprType ty = mkBuiltinTyConApp preprTyCon [ty]
96
97
98 -- |Wrap a type into 'PArray', treating unboxed types specially.
99 --
100 mkPArrayType :: Type -> VM Type
101 mkPArrayType ty
102 | Just tycon <- splitPrimTyCon ty
103 = do { arr <- builtin (parray_PrimTyCon tycon)
104 ; return $ mkTyConApp arr []
105 }
106 mkPArrayType ty = mkBuiltinTyConApp parrayTyCon [ty]
107
108 -- |Checks if a type constructor is defined in 'GHC.Prim' (e.g., 'Int#'); if so, returns it.
109 --
110 splitPrimTyCon :: Type -> Maybe TyCon
111 splitPrimTyCon ty
112 | Just (tycon, []) <- splitTyConApp_maybe ty
113 , isPrimTyCon tycon
114 = Just tycon
115 | otherwise = Nothing
116
117
118 ------
119 mkPArray :: Type -> CoreExpr -> CoreExpr -> VM CoreExpr
120 mkPArray ty len dat = do
121 tc <- builtin parrayTyCon
122 let [dc] = tyConDataCons tc
123 return $ mkConApp dc [Type ty, len, dat]
124
125 mkPDataType :: Type -> VM Type
126 mkPDataType ty = mkBuiltinTyConApp pdataTyCon [ty]
127
128 mkBuiltinCo :: (Builtins -> TyCon) -> VM Coercion
129 mkBuiltinCo get_tc
130 = do
131 tc <- builtin get_tc
132 return $ mkTyConAppCo tc []
133
134 mkVScrut :: VExpr -> VM (CoreExpr, CoreExpr, TyCon, [Type])
135 mkVScrut (ve, le)
136 = do
137 (tc, arg_tys) <- pdataReprTyCon ty
138 return (ve, unwrapFamInstScrut tc arg_tys le, tc, arg_tys)
139 where
140 ty = exprType ve
141
142 -- preprSynTyCon :: Type -> VM (TyCon, [Type])
143 -- preprSynTyCon ty = builtin preprTyCon >>= (`lookupFamInst` [ty])
144
145 pdataReprTyCon :: Type -> VM (TyCon, [Type])
146 pdataReprTyCon ty = builtin pdataTyCon >>= (`lookupFamInst` [ty])
147
148 pdataReprDataCon :: Type -> VM (DataCon, [Type])
149 pdataReprDataCon ty
150 = do
151 (tc, arg_tys) <- pdataReprTyCon ty
152 let [dc] = tyConDataCons tc
153 return (dc, arg_tys)
154
155 prDFunOfTyCon :: TyCon -> VM CoreExpr
156 prDFunOfTyCon tycon
157 = liftM Var
158 . maybeCantVectoriseM "No PR dictionary for tycon" (ppr tycon)
159 $ lookupTyConPR tycon
160