e87c7ca96f78530ee04ad8f14ed362c3103b35bd
[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
126 mkPDataType :: Type -> VM Type
127 mkPDataType ty = mkBuiltinTyConApp pdataTyCon [ty]
128
129
130 mkBuiltinCo :: (Builtins -> TyCon) -> VM Coercion
131 mkBuiltinCo get_tc
132 = do
133 tc <- builtin get_tc
134 return $ mkTyConAppCo tc []
135
136
137 mkVScrut :: VExpr -> VM (CoreExpr, CoreExpr, TyCon, [Type])
138 mkVScrut (ve, le)
139 = do
140 (tc, arg_tys) <- pdataReprTyCon ty
141 return (ve, unwrapFamInstScrut tc arg_tys le, tc, arg_tys)
142 where
143 ty = exprType ve
144
145 preprSynTyCon :: Type -> VM (TyCon, [Type])
146 preprSynTyCon ty = builtin preprTyCon >>= (`lookupFamInst` [ty])
147
148 pdataReprTyCon :: Type -> VM (TyCon, [Type])
149 pdataReprTyCon ty = builtin pdataTyCon >>= (`lookupFamInst` [ty])
150
151
152 pdataReprDataCon :: Type -> VM (DataCon, [Type])
153 pdataReprDataCon ty
154 = do
155 (tc, arg_tys) <- pdataReprTyCon ty
156 let [dc] = tyConDataCons tc
157 return (dc, arg_tys)
158
159 prDFunOfTyCon :: TyCon -> VM CoreExpr
160 prDFunOfTyCon tycon
161 = liftM Var
162 . maybeCantVectoriseM "No PR dictionary for tycon" (ppr tycon)
163 $ lookupTyConPR tycon
164