Base.hs 7.86 KB
Newer Older
1
2
{-# LANGUAGE CPP #-}

3
module Vectorise.Utils.Base
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
  ( voidType
  , newLocalVVar

  , mkDataConTag, dataConTagZ
  , mkWrapType
  , mkClosureTypes
  , mkPReprType
  , mkPDataType, mkPDatasType
  , splitPrimTyCon
  , mkBuiltinCo

  , wrapNewTypeBodyOfWrap
  , unwrapNewTypeBodyOfWrap
  , wrapNewTypeBodyOfPDataWrap
  , unwrapNewTypeBodyOfPDataWrap
  , wrapNewTypeBodyOfPDatasWrap
  , unwrapNewTypeBodyOfPDatasWrap
21

22
23
24
25
  , pdataReprTyCon
  , pdataReprTyConExact
  , pdatasReprTyConExact
  , pdataUnwrapScrut
26

27
  , preprFamInst
28
29
) where

30
31
32
33
34
35
import Vectorise.Monad
import Vectorise.Vect
import Vectorise.Builtins

import CoreSyn
import CoreUtils
36
import FamInstEnv
37
38
39
40
41
import Coercion
import Type
import TyCon
import DataCon
import MkId
42
import DynFlags
43
import FastString
44
45

#include "HsVersions.h"
46

47
-- Simple Types ---------------------------------------------------------------
48

49
50
51
52
53
voidType :: VM Type
voidType = mkBuiltinTyConApp voidTyCon []


-- Name Generation ------------------------------------------------------------
54

55
56
57
58
59
60
61
62
63
64
65
newLocalVVar :: FastString -> Type -> VM VVar
newLocalVVar fs vty
  = do
      lty <- mkPDataType vty
      vv  <- newLocalVar fs vty
      lv  <- newLocalVar fs lty
      return (vv,lv)


-- Constructors ---------------------------------------------------------------

66
67
mkDataConTag :: DynFlags -> DataCon -> CoreExpr
mkDataConTag dflags = mkIntLitInt dflags . dataConTagZ
68
69
70
71
72

dataConTagZ :: DataCon -> Int
dataConTagZ con = dataConTag con - fIRST_TAG


73
-- Type Construction ----------------------------------------------------------
74

75
76
-- |Make an application of the 'Wrap' type constructor.
--
77
mkWrapType :: Type -> VM Type
78
mkWrapType ty = mkBuiltinTyConApp wrapTyCon [ty]
79

80
81
-- |Make an application of the closure type constructor.
--
82
83
84
mkClosureTypes :: [Type] -> Type -> VM Type
mkClosureTypes = mkBuiltinTyConApps closureTyCon

85
86
-- |Make an application of the 'PRepr' type constructor.
--
87
88
89
mkPReprType :: Type -> VM Type
mkPReprType ty = mkBuiltinTyConApp preprTyCon [ty]

90
-- | Make an application of the 'PData' tycon to some argument.
91
--
92
mkPDataType :: Type -> VM Type
93
mkPDataType ty = mkBuiltinTyConApp pdataTyCon [ty]
94
95

-- | Make an application of the 'PDatas' tycon to some argument.
96
--
97
98
mkPDatasType :: Type -> VM Type
mkPDatasType ty = mkBuiltinTyConApp pdatasTyCon [ty]
99

100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
-- Make an application of a builtin type constructor to some arguments.
--
mkBuiltinTyConApp :: (Builtins -> TyCon) -> [Type] -> VM Type
mkBuiltinTyConApp get_tc tys
  = do { tc <- builtin get_tc
       ; return $ mkTyConApp tc tys
       }

-- Make a cascading application of a builtin type constructor.
--
mkBuiltinTyConApps :: (Builtins -> TyCon) -> [Type] -> Type -> VM Type
mkBuiltinTyConApps get_tc tys ty
 = do { tc <- builtin get_tc
      ; return $ foldr (mk tc) ty tys
      }
  where
    mk tc ty1 ty2 = mkTyConApp tc [ty1,ty2]


-- Type decomposition ---------------------------------------------------------
120

121
-- |Checks if a type constructor is defined in 'GHC.Prim' (e.g., 'Int#'); if so, returns it.
122
--
123
124
125
126
127
128
129
130
splitPrimTyCon :: Type -> Maybe TyCon
splitPrimTyCon ty
  | Just (tycon, []) <- splitTyConApp_maybe ty
  , isPrimTyCon tycon
  = Just tycon
  | otherwise = Nothing


131
-- Coercion Construction -----------------------------------------------------
132

133
-- |Make a representational coercion to some builtin type.
134
135
136
137
--
mkBuiltinCo :: (Builtins -> TyCon) -> VM Coercion
mkBuiltinCo get_tc
  = do { tc <- builtin get_tc
138
       ; return $ mkTyConAppCo Representational tc []
139
       }
140

141

142
-- Wrapping and unwrapping the 'Wrap' newtype ---------------------------------
143

144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
-- |Apply the constructor wrapper of the 'Wrap' /newtype/.
--
wrapNewTypeBodyOfWrap :: CoreExpr -> Type -> VM CoreExpr
wrapNewTypeBodyOfWrap e ty
  = do { wrap_tc <- builtin wrapTyCon
       ; return $ wrapNewTypeBody wrap_tc [ty] e
       }

-- |Strip the constructor wrapper of the 'Wrap' /newtype/.
--
unwrapNewTypeBodyOfWrap :: CoreExpr -> Type -> VM CoreExpr
unwrapNewTypeBodyOfWrap e ty
  = do { wrap_tc <- builtin wrapTyCon
       ; return $ unwrapNewTypeBody wrap_tc [ty] e
       }
159

160
161
162
163
164
165
-- |Apply the constructor wrapper of the 'PData' /newtype/ instance of 'Wrap'.
--
wrapNewTypeBodyOfPDataWrap :: CoreExpr -> Type -> VM CoreExpr
wrapNewTypeBodyOfPDataWrap e ty
  = do { wrap_tc  <- builtin wrapTyCon
       ; pwrap_tc <- pdataReprTyConExact wrap_tc
166
       ; return $ wrapNewTypeBody pwrap_tc [ty] e
167
       }
168

169
170
171
172
173
174
175
176
-- |Strip the constructor wrapper of the 'PData' /newtype/ instance of 'Wrap'.
--
unwrapNewTypeBodyOfPDataWrap :: CoreExpr -> Type -> VM CoreExpr
unwrapNewTypeBodyOfPDataWrap e ty
  = do { wrap_tc  <- builtin wrapTyCon
       ; pwrap_tc <- pdataReprTyConExact wrap_tc
       ; return $ unwrapNewTypeBody pwrap_tc [ty] (unwrapFamInstScrut pwrap_tc [ty] e)
       }
177

178
179
180
181
182
183
-- |Apply the constructor wrapper of the 'PDatas' /newtype/ instance of 'Wrap'.
--
wrapNewTypeBodyOfPDatasWrap :: CoreExpr -> Type -> VM CoreExpr
wrapNewTypeBodyOfPDatasWrap e ty
  = do { wrap_tc  <- builtin wrapTyCon
       ; pwrap_tc <- pdatasReprTyConExact wrap_tc
184
       ; return $ wrapNewTypeBody pwrap_tc [ty] e
185
186
187
188
189
190
191
192
193
194
195
196
197
       }

-- |Strip the constructor wrapper of the 'PDatas' /newtype/ instance of 'Wrap'.
--
unwrapNewTypeBodyOfPDatasWrap :: CoreExpr -> Type -> VM CoreExpr
unwrapNewTypeBodyOfPDatasWrap e ty
  = do { wrap_tc  <- builtin wrapTyCon
       ; pwrap_tc <- pdatasReprTyConExact wrap_tc
       ; return $ unwrapNewTypeBody pwrap_tc [ty] (unwrapFamInstScrut pwrap_tc [ty] e)
       }


-- 'PData' representation types ----------------------------------------------
198

199
200
201
202
-- |Get the representation tycon of the 'PData' data family for a given type.
--
-- This tycon does not appear explicitly in the source program — see Note [PData TyCons] in
-- 'Vectorise.Generic.Description':
203
204
205
--
--   @pdataReprTyCon {Sum2} = {PDataSum2}@
--
206
207
208
-- The type for which we look up a 'PData' instance may be more specific than the type in the
-- instance declaration.  In that case the second component of the result will be more specific than
-- a set of distinct type variables.
209
--
210
pdataReprTyCon :: Type -> VM (TyCon, [Type])
211
212
pdataReprTyCon ty
  = do
213
214
    { FamInstMatch { fim_instance = famInst
                   , fim_tys      = tys } <- builtin pdataTyCon >>= (`lookupFamInst` [ty])
215
    ; return (dataFamInstRepTyCon famInst, tys)
216
    }
217

218
219
220
221
222
223
224
-- |Get the representation tycon of the 'PData' data family for a given type constructor.
--
-- For example, for a binary type constructor 'T', we determine the representation type constructor
-- for 'PData (T a b)'.
--
pdataReprTyConExact :: TyCon -> VM TyCon
pdataReprTyConExact tycon
225
  = do {   -- look up the representation tycon; if there is a match at all, it will be exact
226
227
228
       ;   -- (i.e.,' _tys' will be distinct type variables)
       ; (ptycon, _tys) <- pdataReprTyCon (tycon `mkTyConApp` mkTyVarTys (tyConTyVars tycon))
       ; return ptycon
229
       }
230

231
232
233
234
235
236
237
-- |Get the representation tycon of the 'PDatas' data family for a given type constructor.
--
-- For example, for a binary type constructor 'T', we determine the representation type constructor
-- for 'PDatas (T a b)'.
--
pdatasReprTyConExact :: TyCon -> VM TyCon
pdatasReprTyConExact tycon
238
  = do {   -- look up the representation tycon; if there is a match at all, it will be exact
239
       ; (FamInstMatch { fim_instance = ptycon }) <- pdatasReprTyCon (tycon `mkTyConApp` mkTyVarTys (tyConTyVars tycon))
240
       ; return $ dataFamInstRepTyCon ptycon
241
242
243
       }
  where
    pdatasReprTyCon ty = builtin pdatasTyCon >>= (`lookupFamInst` [ty])
244

245
246
247
248
249
-- |Unwrap a 'PData' representation scrutinee.
--
pdataUnwrapScrut :: VExpr -> VM (CoreExpr, CoreExpr, DataCon)
pdataUnwrapScrut (ve, le)
  = do { (tc, arg_tys) <- pdataReprTyCon ty
250
       ; let [dc] = tyConDataCons tc
251
       ; return (ve, unwrapFamInstScrut tc arg_tys le, dc)
252
       }
253
254
  where
    ty = exprType ve
255
256
257
258
259
260


-- 'PRepr' representation types ----------------------------------------------

-- |Get the representation tycon of the 'PRepr' type family for a given type.
--
261
262
preprFamInst :: Type -> VM FamInstMatch
preprFamInst ty = builtin preprTyCon >>= (`lookupFamInst` [ty])