VectType.hs 34.7 KB
Newer Older
1

2
module VectType ( vectTyCon, vectAndLiftType, vectType, vectTypeEnv,
rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
3
                  mkRepr, arrShapeTys, arrShapeVars, arrSelector,
Ian Lynagh's avatar
Ian Lynagh committed
4
                  buildPADict,
5
                  fromVect )
6
7
8
9
where

import VectMonad
import VectUtils
rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
10
import VectCore
11

12
import HscTypes          ( TypeEnv, extendTypeEnvList, typeEnvTyCons )
rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
13
import CoreSyn
rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
14
import CoreUtils
15
import BuildTyCl
16
import DataCon
17
18
19
import TyCon
import Type
import TypeRep
20
import Coercion
21
import FamInstEnv        ( FamInst, mkLocalFamInst )
22
23
import OccName
import MkId
Ian Lynagh's avatar
Ian Lynagh committed
24
import BasicTypes        ( StrictnessMark(..), boolToRecFlag )
25
import Var               ( Var, TyVar )
rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
26
import Id                ( mkWildId )
27
import Name              ( Name, getOccName )
28
import NameEnv
29
import TysWiredIn
rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
30
import TysPrim           ( intPrimTy )
31

32
import Unique
33
import UniqFM
34
import UniqSet
35
import Util
36
import Digraph           ( SCC(..), stronglyConnCompFromEdgedVertices )
37

38
import Outputable
39
import FastString
40

41
import Control.Monad  ( liftM, liftM2, zipWithM, zipWithM_, mapAndUnzipM )
42
import Data.List      ( inits, tails, zipWith4, zipWith5 )
43

rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
44
45
46
-- ----------------------------------------------------------------------------
-- Types

47
48
49
50
51
52
53
54
55
56
57
58
59
vectTyCon :: TyCon -> VM TyCon
vectTyCon tc
  | isFunTyCon tc        = builtin closureTyCon
  | isBoxedTupleTyCon tc = return tc
  | isUnLiftedTyCon tc   = return tc
  | otherwise = do
                  r <- lookupTyCon tc
                  case r of
                    Just tc' -> return tc'

                    -- FIXME: just for now
                    Nothing  -> pprTrace "ccTyCon:" (ppr tc) $ return tc

60
61
62
63
64
65
66
67
68
69
70
71
72
73
vectAndLiftType :: Type -> VM (Type, Type)
vectAndLiftType ty | Just ty' <- coreView ty = vectAndLiftType ty'
vectAndLiftType ty
  = do
      mdicts   <- mapM paDictArgType tyvars
      let dicts = [dict | Just dict <- mdicts]
      vmono_ty <- vectType mono_ty
      lmono_ty <- mkPArrayType vmono_ty
      return (abstractType tyvars dicts vmono_ty,
              abstractType tyvars dicts lmono_ty)
  where
    (tyvars, mono_ty) = splitForAllTys ty


74
75
76
77
78
79
vectType :: Type -> VM Type
vectType ty | Just ty' <- coreView ty = vectType ty'
vectType (TyVarTy tv) = return $ TyVarTy tv
vectType (AppTy ty1 ty2) = liftM2 AppTy (vectType ty1) (vectType ty2)
vectType (TyConApp tc tys) = liftM2 TyConApp (vectTyCon tc) (mapM vectType tys)
vectType (FunTy ty1 ty2)   = liftM2 TyConApp (builtin closureTyCon)
80
                                             (mapM vectAndBoxType [ty1,ty2])
81
82
83
84
vectType ty@(ForAllTy _ _)
  = do
      mdicts   <- mapM paDictArgType tyvars
      mono_ty' <- vectType mono_ty
85
      return $ abstractType tyvars [dict | Just dict <- mdicts] mono_ty'
86
87
88
89
90
  where
    (tyvars, mono_ty) = splitForAllTys ty

vectType ty = pprPanic "vectType:" (ppr ty)

91
92
93
vectAndBoxType :: Type -> VM Type
vectAndBoxType ty = vectType ty >>= boxType

94
95
96
abstractType :: [TyVar] -> [Type] -> Type -> Type
abstractType tyvars dicts = mkForAllTys tyvars . mkFunTys dicts

97
98
99
100
101
102
103
104
105
106
107
108
109
110
-- ----------------------------------------------------------------------------
-- Boxing

boxType :: Type -> VM Type
boxType ty
  | Just (tycon, []) <- splitTyConApp_maybe ty
  , isUnLiftedTyCon tycon
  = do
      r <- lookupBoxedTyCon tycon
      case r of
        Just tycon' -> return $ mkTyConApp tycon' []
        Nothing     -> return ty
boxType ty = return ty

111
112
113
114
115
-- ----------------------------------------------------------------------------
-- Type definitions

type TyConGroup = ([TyCon], UniqSet TyCon)

116
vectTypeEnv :: TypeEnv -> VM (TypeEnv, [FamInst], [(Var, CoreExpr)])
117
118
119
120
121
122
123
vectTypeEnv env
  = do
      cs <- readGEnv $ mk_map . global_tycons
      let (conv_tcs, keep_tcs) = classifyTyCons cs groups
          keep_dcs             = concatMap tyConDataCons keep_tcs
      zipWithM_ defTyCon   keep_tcs keep_tcs
      zipWithM_ defDataCon keep_dcs keep_dcs
124
125
126
127
128
      new_tcs <- vectTyConDecls conv_tcs

      let orig_tcs = keep_tcs ++ conv_tcs
          vect_tcs  = keep_tcs ++ new_tcs

129
      repr_tcs <- zipWithM buildPReprTyCon   orig_tcs vect_tcs
130
      parr_tcs <- zipWithM buildPArrayTyCon orig_tcs vect_tcs
131
132
      dfuns    <- mapM mkPADFun vect_tcs
      defTyConPAs (zip vect_tcs dfuns)
133
134
135
136
137
138
      binds    <- sequence (zipWith5 buildTyConBindings orig_tcs
                                                        vect_tcs
                                                        repr_tcs
                                                        parr_tcs
                                                        dfuns)

139
      let all_new_tcs = new_tcs ++ repr_tcs ++ parr_tcs
140
141

      let new_env = extendTypeEnvList env
142
143
                       (map ATyCon all_new_tcs
                        ++ [ADataCon dc | tc <- all_new_tcs
144
145
                                        , dc <- tyConDataCons tc])

146
      return (new_env, map mkLocalFamInst (repr_tcs ++ parr_tcs), concat binds)
147
148
149
150
151
152
153
  where
    tycons = typeEnvTyCons env
    groups = tyConGroups tycons

    mk_map env = listToUFM_Directly [(u, getUnique n /= u) | (u,n) <- nameEnvUniqueElts env]


154
155
156
vectTyConDecls :: [TyCon] -> VM [TyCon]
vectTyConDecls tcs = fixV $ \tcs' ->
  do
157
    mapM_ (uncurry defTyCon) (zipLazy tcs tcs')
158
159
160
161
162
163
164
165
    mapM vectTyConDecl tcs

vectTyConDecl :: TyCon -> VM TyCon
vectTyConDecl tc
  = do
      name' <- cloneName mkVectTyConOcc name
      rhs'  <- vectAlgTyConRhs (algTyConRhs tc)

166
167
168
169
170
171
172
173
      liftDs $ buildAlgTyCon name'
                             tyvars
                             []           -- no stupid theta
                             rhs'
                             rec_flag     -- FIXME: is this ok?
                             False        -- FIXME: no generics
                             False        -- not GADT syntax
                             Nothing      -- not a family instance
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
  where
    name   = tyConName tc
    tyvars = tyConTyVars tc
    rec_flag = boolToRecFlag (isRecursiveTyCon tc)

vectAlgTyConRhs :: AlgTyConRhs -> VM AlgTyConRhs
vectAlgTyConRhs (DataTyCon { data_cons = data_cons
                           , is_enum   = is_enum
                           })
  = do
      data_cons' <- mapM vectDataCon data_cons
      zipWithM_ defDataCon data_cons data_cons'
      return $ DataTyCon { data_cons = data_cons'
                         , is_enum   = is_enum
                         }
Ian Lynagh's avatar
Ian Lynagh committed
189
vectAlgTyConRhs _ = panic "vectAlgTyConRhs"
190
191
192
193
194
195
196
197
198
199

vectDataCon :: DataCon -> VM DataCon
vectDataCon dc
  | not . null $ dataConExTyVars dc = pprPanic "vectDataCon: existentials" (ppr dc)
  | not . null $ dataConEqSpec   dc = pprPanic "vectDataCon: eq spec" (ppr dc)
  | otherwise
  = do
      name'    <- cloneName mkVectDataConOcc name
      tycon'   <- vectTyCon tycon
      arg_tys  <- mapM vectType rep_arg_tys
200
201
202
203
204
205
206
207
208
209
210

      liftDs $ buildDataCon name'
                            False           -- not infix
                            (map (const NotMarkedStrict) arg_tys)
                            []              -- no labelled fields
                            univ_tvs
                            []              -- no existential tvs for now
                            []              -- no eq spec for now
                            []              -- no context
                            arg_tys
                            tycon'
211
212
213
  where
    name        = dataConName dc
    univ_tvs    = dataConUnivTyVars dc
rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
214
    rep_arg_tys = dataConRepArgTys dc
215
216
    tycon       = dataConTyCon dc

217
218
219
220
mk_fam_inst :: TyCon -> TyCon -> (TyCon, [Type])
mk_fam_inst fam_tc arg_tc
  = (fam_tc, [mkTyConApp arg_tc . mkTyVarTys $ tyConTyVars arg_tc])

rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
221
222
223
224
buildPReprTyCon :: TyCon -> TyCon -> VM TyCon
buildPReprTyCon orig_tc vect_tc
  = do
      name     <- cloneName mkPReprTyConOcc (tyConName orig_tc)
225
      rhs_ty   <- buildPReprType vect_tc
rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
226
227
228
229
230
231
232
233
      prepr_tc <- builtin preprTyCon
      liftDs $ buildSynTyCon name
                             tyvars
                             (SynonymTyCon rhs_ty)
                             (Just $ mk_fam_inst prepr_tc vect_tc)
  where
    tyvars = tyConTyVars vect_tc

234

235
236
237
238
239
240
241
data Repr = ProdRepr {
              prod_components   :: [Type]
            , prod_tycon        :: TyCon
            , prod_data_con     :: DataCon
            , prod_arr_tycon    :: TyCon
            , prod_arr_data_con :: DataCon
            }
242

243
244
245
246
247
248
249
          | SumRepr {
              sum_components    :: [Repr]
            , sum_tycon         :: TyCon
            , sum_arr_tycon     :: TyCon
            , sum_arr_data_con  :: DataCon
            }

250
251
          | IdRepr Type

252
253
254
255
256
          | VoidRepr {
              void_tycon        :: TyCon
            , void_bottom       :: CoreExpr
            }

257
258
259
260
261
262
263
          | EnumRepr {
              enum_tycon        :: TyCon
            , enum_data_con     :: DataCon
            , enum_arr_tycon    :: TyCon
            , enum_arr_data_con :: DataCon
            }

rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
264
265
266
267
268
269
270
271
272
273
voidRepr :: VM Repr
voidRepr
  = do
      tycon <- builtin voidTyCon
      var   <- builtin voidVar
      return $ VoidRepr {
                 void_tycon  = tycon
               , void_bottom = Var var
               }

Ian Lynagh's avatar
Ian Lynagh committed
274
{-
275
276
277
enumRepr :: VM Repr
enumRepr
  = do
278
279
280
      tycon <- builtin enumerationTyCon
      let [data_con] = tyConDataCons tycon
      (arr_tycon, _) <- parrayReprTyCon (mkTyConApp tycon [])
281
282
283
284
285
286
287
288
      let [arr_data_con] = tyConDataCons arr_tycon

      return $ EnumRepr {
                 enum_tycon       = tycon
               , enum_data_con     = data_con
               , enum_arr_tycon    = arr_tycon
               , enum_arr_data_con = arr_data_con
               }
Ian Lynagh's avatar
Ian Lynagh committed
289
-}
290

rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
291
292
293
294
295
296
297
unboxedProductRepr :: [Type] -> VM Repr
unboxedProductRepr []   = voidRepr
unboxedProductRepr [ty] = return $ IdRepr ty
unboxedProductRepr tys  = boxedProductRepr tys

boxedProductRepr :: [Type] -> VM Repr
boxedProductRepr tys
298
299
300
  = do
      tycon <- builtin (prodTyCon arity)
      let [data_con] = tyConDataCons tycon
301

302
303
      tys' <- mapM boxType tys
      (arr_tycon, _) <- parrayReprTyCon $ mkTyConApp tycon tys'
304
305
      let [arr_data_con] = tyConDataCons arr_tycon

306
      return $ ProdRepr {
307
308
309
310
311
                 prod_components   = tys
               , prod_tycon        = tycon
               , prod_data_con     = data_con
               , prod_arr_tycon    = arr_tycon
               , prod_arr_data_con = arr_data_con
312
               }
313
314
  where
    arity = length tys
315

rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
316
317
318
319
sumRepr :: [Repr] -> VM Repr
sumRepr []     = voidRepr
sumRepr [repr] = boxRepr repr
sumRepr reprs
320
  = do
321
322
323
324
325
326
      tycon <- builtin (sumTyCon arity)
      (arr_tycon, _) <- parrayReprTyCon
                      . mkTyConApp tycon
                      $ map reprType reprs

      let [arr_data_con] = tyConDataCons arr_tycon
327
328

      return $ SumRepr {
329
330
331
332
                 sum_components   = reprs
               , sum_tycon        = tycon
               , sum_arr_tycon    = arr_tycon
               , sum_arr_data_con = arr_data_con
333
334
               }
  where
335
    arity = length reprs
336

rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
337
338
339
340
splitSumRepr :: Repr -> [Repr]
splitSumRepr (SumRepr { sum_components = reprs }) = reprs
splitSumRepr repr                                 = [repr]

rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
341
342
343
344
345
boxRepr :: Repr -> VM Repr
boxRepr (VoidRepr {}) = boxedProductRepr []
boxRepr (IdRepr ty)   = boxedProductRepr [ty]
boxRepr repr          = return repr

346
347
348
349
350
reprType :: Repr -> Type
reprType (ProdRepr { prod_tycon = tycon, prod_components = tys })
  = mkTyConApp tycon tys
reprType (SumRepr { sum_tycon = tycon, sum_components = reprs })
  = mkTyConApp tycon (map reprType reprs)
351
reprType (IdRepr ty) = ty
352
reprType (VoidRepr { void_tycon = tycon }) = mkTyConApp tycon []
353
reprType (EnumRepr { enum_tycon = tycon }) = mkTyConApp tycon []
354

355
356
arrReprType :: Repr -> VM Type
arrReprType = mkPArrayType . reprType
357

358
arrShapeTys :: Repr -> VM [Type]
359
arrShapeTys (SumRepr  {}) = sumShapeTys
360
361
arrShapeTys (ProdRepr {}) = return [intPrimTy]
arrShapeTys (IdRepr _)    = return []
362
arrShapeTys (VoidRepr {}) = return [intPrimTy]
363
364
365
366
arrShapeTys (EnumRepr {}) = sumShapeTys

sumShapeTys :: VM [Type]
sumShapeTys = do
367
368
                int_arr <- builtin intPrimArrayTy
                return [intPrimTy, int_arr, int_arr]
369

370

371
arrShapeVars :: Repr -> VM [Var]
Ian Lynagh's avatar
Ian Lynagh committed
372
arrShapeVars repr = mapM (newLocalVar (fsLit "sh")) =<< arrShapeTys repr
373

374
replicateShape :: Repr -> CoreExpr -> CoreExpr -> VM [CoreExpr]
375
376
377
378
379
380
381
382
replicateShape (ProdRepr {}) len _   = return [len]
replicateShape (SumRepr {})  len tag = replicateSumShape len tag
replicateShape (IdRepr _) _ _        = return []
replicateShape (VoidRepr {}) len _   = return [len]
replicateShape (EnumRepr {}) len tag = replicateSumShape len tag

replicateSumShape :: CoreExpr -> CoreExpr -> VM [CoreExpr]
replicateSumShape len tag
383
384
385
386
  = do
      rep <- builtin replicatePAIntPrimVar
      up  <- builtin upToPAIntPrimVar
      return [len, Var rep `mkApps` [len, tag], Var up `App` len]
387

388
arrSelector :: Repr -> [CoreExpr] -> VM (CoreExpr, CoreExpr, CoreExpr)
389
390
arrSelector (SumRepr {})  [len, sel, is] = return (len, sel, is)
arrSelector (EnumRepr {}) [len, sel, is] = return (len, sel, is)
Ian Lynagh's avatar
Ian Lynagh committed
391
arrSelector _             _              = panic "arrSelector"
rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
392

rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
393
394
395
396
397
398
399
400
401
402
403
emptyArrRepr :: Repr -> VM [CoreExpr]
emptyArrRepr (SumRepr { sum_components = prods })
  = liftM concat $ mapM emptyArrRepr prods
emptyArrRepr (ProdRepr { prod_components = [] })
  = return [Var unitDataConId]
emptyArrRepr (ProdRepr { prod_components = tys })
  = mapM emptyPA tys
emptyArrRepr (IdRepr ty)
  = liftM singleton $ emptyPA ty
emptyArrRepr (VoidRepr { void_tycon = tycon })
  = liftM singleton $ emptyPA (mkTyConApp tycon [])
Ian Lynagh's avatar
Ian Lynagh committed
404
emptyArrRepr (EnumRepr {})
405
  = return []
rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
406
407
408
409
410
411
412
413
414
415
416
417

arrReprTys :: Repr -> VM [Type]
arrReprTys (SumRepr { sum_components = reprs })
  = liftM concat $ mapM arrReprTys reprs
arrReprTys (ProdRepr { prod_components = [] })
  = return [unitTy]
arrReprTys (ProdRepr { prod_components = tys })
  = mapM mkPArrayType tys
arrReprTys (IdRepr ty)
  = liftM singleton $ mkPArrayType ty
arrReprTys (VoidRepr { void_tycon = tycon })
  = liftM singleton $ mkPArrayType (mkTyConApp tycon [])
418
arrReprTys (EnumRepr {})
419
  = return []
rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
420
421
422
423
424

arrReprTys' :: Repr -> VM [[Type]]
arrReprTys' (SumRepr { sum_components = reprs })
  = mapM arrReprTys reprs
arrReprTys' repr = liftM singleton $ arrReprTys repr
425
426
427

arrReprVars :: Repr -> VM [[Var]]
arrReprVars repr
Ian Lynagh's avatar
Ian Lynagh committed
428
  = mapM (mapM (newLocalVar (fsLit "rs"))) =<< arrReprTys' repr
429
430
431

mkRepr :: TyCon -> VM Repr
mkRepr vect_tc
432
  | [tys] <- rep_tys = boxedProductRepr tys
Thomas Schilling's avatar
Thomas Schilling committed
433
  -- removed: | all null rep_tys = enumRepr
434
  | otherwise        = sumRepr =<< mapM unboxedProductRepr rep_tys
435
436
  where
    rep_tys = map dataConRepArgTys $ tyConDataCons vect_tc
437
438
439
440
441
442

buildPReprType :: TyCon -> VM Type
buildPReprType = liftM reprType . mkRepr

buildToPRepr :: Repr -> TyCon -> TyCon -> TyCon -> VM CoreExpr
buildToPRepr repr vect_tc prepr_tc _
rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
443
  = do
Ian Lynagh's avatar
Ian Lynagh committed
444
      arg    <- newLocalVar (fsLit "x") arg_ty
445
      result <- to_repr repr (Var arg)
rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
446

447
448
449
      return . Lam arg
             . wrapFamInstBody prepr_tc var_tys
             $ result
rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
450
  where
451
452
453
    var_tys = mkTyVarTys $ tyConTyVars vect_tc
    arg_ty  = mkTyConApp vect_tc var_tys
    res_ty  = reprType repr
rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
454

455
456
    cons    = tyConDataCons vect_tc
    [con]   = cons
457

458
459
460
    to_repr (SumRepr { sum_components = prods
                     , sum_tycon      = tycon })
            expr
rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
461
      = do
rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
462
          (vars, bodies) <- mapAndUnzipM to_unboxed prods
463
464
465
466
467
468
469
470
          return . Case expr (mkWildId (exprType expr)) res_ty
                 $ zipWith4 mk_alt cons vars (tyConDataCons tycon) bodies
      where
        mk_alt con vars sum_con body
          = (DataAlt con, vars, mkConApp sum_con (ty_args ++ [body]))

        ty_args = map (Type . reprType) prods

471
472
473
474
475
476
    to_repr (EnumRepr { enum_data_con = data_con }) expr
      = return . Case expr (mkWildId (exprType expr)) res_ty
               $ map mk_alt cons
      where
        mk_alt con = (DataAlt con, [], mkConApp data_con [mkDataConTag con])

477
    to_repr prod expr
rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
478
      = do
rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
479
          (vars, body) <- to_unboxed prod
480
481
          return $ Case expr (mkWildId (exprType expr)) res_ty
                   [(DataAlt con, vars, body)]
rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
482

rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
483
484
    to_unboxed (ProdRepr { prod_components = tys
                         , prod_data_con   = data_con })
rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
485
      = do
Ian Lynagh's avatar
Ian Lynagh committed
486
          vars <- mapM (newLocalVar (fsLit "r")) tys
487
          return (vars, mkConApp data_con (map Type tys ++ map Var vars))
rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
488

rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
489
    to_unboxed (IdRepr ty)
490
      = do
Ian Lynagh's avatar
Ian Lynagh committed
491
          var <- newLocalVar (fsLit "y") ty
492
493
          return ([var], Var var)

rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
494
    to_unboxed (VoidRepr { void_bottom = bottom })
495
496
      = return ([], bottom)

Ian Lynagh's avatar
Ian Lynagh committed
497
498
    to_unboxed _ = panic "buildToPRepr/to_unboxed"

499

500
501
502
503
buildFromPRepr :: Repr -> TyCon -> TyCon -> TyCon -> VM CoreExpr
buildFromPRepr repr vect_tc prepr_tc _
  = do
      arg_ty <- mkPReprType res_ty
Ian Lynagh's avatar
Ian Lynagh committed
504
      arg    <- newLocalVar (fsLit "x") arg_ty
rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
505

506
507
508
509
510
511
      liftM (Lam arg)
           . from_repr repr
           $ unwrapFamInstScrut prepr_tc var_tys (Var arg)
  where
    var_tys = mkTyVarTys $ tyConTyVars vect_tc
    res_ty  = mkTyConApp vect_tc var_tys
rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
512

513
514
    cons    = map (`mkConApp` map Type var_tys) (tyConDataCons vect_tc)
    [con]   = cons
rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
515

516
517
518
519
    from_repr repr@(SumRepr { sum_components = prods
                            , sum_tycon      = tycon })
              expr
      = do
Ian Lynagh's avatar
Ian Lynagh committed
520
          vars   <- mapM (newLocalVar (fsLit "x")) (map reprType prods)
rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
521
          bodies <- sequence . zipWith3 from_unboxed prods cons
522
523
524
525
526
                             $ map Var vars
          return . Case expr (mkWildId (reprType repr)) res_ty
                 $ zipWith3 sum_alt (tyConDataCons tycon) vars bodies
      where
        sum_alt data_con var body = (DataAlt data_con, [var], body)
rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
527

528
529
    from_repr repr@(EnumRepr { enum_data_con = data_con }) expr
      = do
Ian Lynagh's avatar
Ian Lynagh committed
530
          var <- newLocalVar (fsLit "n") intPrimTy
531
532
533
534
535
536
537
538
539
540
541
542
543
544

          let res = Case (Var var) (mkWildId intPrimTy) res_ty
                  $ (DEFAULT, [], error_expr)
                  : zipWith mk_alt (tyConDataCons vect_tc) cons

          return $ Case expr (mkWildId (reprType repr)) res_ty
                   [(DataAlt data_con, [var], res)]
      where
        mk_alt data_con con = (LitAlt (mkDataConTagLit data_con), [], con)

        error_expr = mkRuntimeErrorApp rUNTIME_ERROR_ID res_ty
                   . showSDoc
                   $ sep [text "Invalid NDP representation of", ppr vect_tc]

rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
545
    from_repr repr expr = from_unboxed repr con expr
546

rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
547
548
    from_unboxed prod@(ProdRepr { prod_components = tys
                                , prod_data_con   = data_con })
549
550
551
              con
              expr
      = do
Ian Lynagh's avatar
Ian Lynagh committed
552
          vars <- mapM (newLocalVar (fsLit "y")) tys
553
554
555
          return $ Case expr (mkWildId (reprType prod)) res_ty
                   [(DataAlt data_con, vars, con `mkVarApps` vars)]

rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
556
    from_unboxed (IdRepr _) con expr
557
558
       = return $ con `App` expr

Ian Lynagh's avatar
Ian Lynagh committed
559
    from_unboxed (VoidRepr {}) con _
560
561
       = return con

Ian Lynagh's avatar
Ian Lynagh committed
562
563
    from_unboxed _ _ _ = panic "buildFromPRepr/from_unboxed"

564
565
buildToArrPRepr :: Repr -> TyCon -> TyCon -> TyCon -> VM CoreExpr
buildToArrPRepr repr vect_tc prepr_tc arr_tc
566
  = do
567
      arg_ty     <- mkPArrayType el_ty
Ian Lynagh's avatar
Ian Lynagh committed
568
      arg        <- newLocalVar (fsLit "xs") arg_ty
569
570
571
572
573

      res_ty     <- mkPArrayType (reprType repr)

      shape_vars <- arrShapeVars repr
      repr_vars  <- arrReprVars  repr
574
575
576

      parray_co  <- mkBuiltinCo parrayTyCon

577
578
579
580
581
582
      let Just repr_co = tyConFamilyCoercion_maybe prepr_tc
          co           = mkAppCoercion parray_co
                       . mkSymCoercion
                       $ mkTyConApp repr_co var_tys

          scrut   = unwrapFamInstScrut arr_tc var_tys (Var arg)
583

584
      result <- to_repr shape_vars repr_vars repr
585
586
587

      return . Lam arg
             . mkCoerce co
588
589
             $ Case scrut (mkWildId (mkTyConApp arr_tc var_tys)) res_ty
               [(DataAlt arr_dc, shape_vars ++ concat repr_vars, result)]
590
591
592
  where
    var_tys = mkTyVarTys $ tyConTyVars vect_tc
    el_ty   = mkTyConApp vect_tc var_tys
593
594
595

    [arr_dc] = tyConDataCons arr_tc

Ian Lynagh's avatar
Ian Lynagh committed
596
    to_repr shape_vars@(_ : _)
597
598
599
600
601
            repr_vars
            (SumRepr { sum_components   = prods
                     , sum_arr_tycon    = tycon
                     , sum_arr_data_con = data_con })
      = do
602
          exprs <- zipWithM to_prod repr_vars prods
603

604
605
606
607
608
          return . wrapFamInstBody tycon tys
                 . mkConApp data_con
                 $ map Type tys ++ map Var shape_vars ++ exprs
      where
        tys = map reprType prods
609

610
611
612
613
614
615
616
617
    to_repr [len_var]
            [repr_vars]
            (ProdRepr { prod_components   = tys
                      , prod_arr_tycon    = tycon
                      , prod_arr_data_con = data_con })
       = return . wrapFamInstBody tycon tys
                . mkConApp data_con
                $ map Type tys ++ map Var (len_var : repr_vars)
618

619
620
    to_repr shape_vars
            _
621
622
623
            (EnumRepr { enum_arr_tycon    = tycon
                      , enum_arr_data_con = data_con })
      = return . wrapFamInstBody tycon []
624
625
               . mkConApp data_con
                $ map Var shape_vars
626

Ian Lynagh's avatar
Ian Lynagh committed
627
628
    to_repr _ _ _ = panic "buildToArrPRepr/to_repr"

629
    to_prod repr_vars@(r : _)
630
            (ProdRepr { prod_components   = tys@(ty : _)
631
632
                      , prod_arr_tycon    = tycon
                      , prod_arr_data_con = data_con })
633
      = do
634
          len <- lengthPA ty (Var r)
635
636
637
638
          return . wrapFamInstBody tycon tys
                 . mkConApp data_con
                 $ map Type tys ++ len : map Var repr_vars

Ian Lynagh's avatar
Ian Lynagh committed
639
    to_prod [var] (IdRepr _)    = return (Var var)
640
    to_prod [var] (VoidRepr {}) = return (Var var)
Ian Lynagh's avatar
Ian Lynagh committed
641
    to_prod _     _             = panic "buildToArrPRepr/to_prod"
642

643

644
645
buildFromArrPRepr :: Repr -> TyCon -> TyCon -> TyCon -> VM CoreExpr
buildFromArrPRepr repr vect_tc prepr_tc arr_tc
646
  = do
647
      arg_ty     <- mkPArrayType =<< mkPReprType el_ty
Ian Lynagh's avatar
Ian Lynagh committed
648
      arg        <- newLocalVar (fsLit "xs") arg_ty
649

650
651
652
653
      res_ty     <- mkPArrayType el_ty

      shape_vars <- arrShapeVars repr
      repr_vars  <- arrReprVars  repr
654
655
656

      parray_co  <- mkBuiltinCo parrayTyCon

657
658
659
      let Just repr_co = tyConFamilyCoercion_maybe prepr_tc
          co           = mkAppCoercion parray_co
                       $ mkTyConApp repr_co var_tys
660

661
          scrut  = mkCoerce co (Var arg)
662

663
664
665
          result = wrapFamInstBody arr_tc var_tys
                 . mkConApp arr_dc
                 $ map Type var_tys ++ map Var (shape_vars ++ concat repr_vars)
666

667
668
      liftM (Lam arg)
            (from_repr repr scrut shape_vars repr_vars res_ty result)
669
670
671
672
673
  where
    var_tys = mkTyVarTys $ tyConTyVars vect_tc
    el_ty   = mkTyConApp vect_tc var_tys

    [arr_dc] = tyConDataCons arr_tc
674

675
676
677
678
679
680
681
682
683
    from_repr (SumRepr { sum_components   = prods
                       , sum_arr_tycon    = tycon
                       , sum_arr_data_con = data_con })
              expr
              shape_vars
              repr_vars
              res_ty
              body
      = do
Ian Lynagh's avatar
Ian Lynagh committed
684
          vars <- mapM (newLocalVar (fsLit "xs")) =<< mapM arrReprType prods
685
686
687
688
689
690
691
692
693
694
695
696
          result <- go prods repr_vars vars body

          let scrut = unwrapFamInstScrut tycon ty_args expr
          return . Case scrut (mkWildId scrut_ty) res_ty
                 $ [(DataAlt data_con, shape_vars ++ vars, result)]
      where
        ty_args  = map reprType prods
        scrut_ty = mkTyConApp tycon ty_args

        go [] [] [] body = return body
        go (prod : prods) (repr_vars : rss) (var : vars) body
          = do
Ian Lynagh's avatar
Ian Lynagh committed
697
              shape_vars <- mapM (newLocalVar (fsLit "s")) =<< arrShapeTys prod
698
699
700

              from_prod prod (Var var) shape_vars repr_vars res_ty
                =<< go prods rss vars body
Ian Lynagh's avatar
Ian Lynagh committed
701
        go _ _ _ _ = panic "buildFromArrPRepr/go"
702
703
704
705

    from_repr repr expr shape_vars [repr_vars] res_ty body
      = from_prod repr expr shape_vars repr_vars res_ty body

Ian Lynagh's avatar
Ian Lynagh committed
706
707
    from_repr _ _ _ _ _ _ = panic "buildFromArrPRepr/from_repr"

708
709
710
    from_prod (ProdRepr { prod_components = tys
                        , prod_arr_tycon  = tycon
                        , prod_arr_data_con = data_con })
711
712
713
714
715
716
717
718
719
720
721
722
              expr
              shape_vars
              repr_vars
              res_ty
              body
      = do
          let scrut    = unwrapFamInstScrut tycon tys expr
              scrut_ty = mkTyConApp tycon tys

          return $ Case scrut (mkWildId scrut_ty) res_ty
                   [(DataAlt data_con, shape_vars ++ repr_vars, body)]

723
724
725
    from_prod (EnumRepr { enum_arr_tycon = tycon
                        , enum_arr_data_con = data_con })
              expr
726
727
              shape_vars
              _
728
729
730
731
732
733
              res_ty
              body
      = let scrut    = unwrapFamInstScrut tycon [] expr
            scrut_ty = mkTyConApp tycon []
        in
        return $ Case scrut (mkWildId scrut_ty) res_ty
734
                 [(DataAlt data_con, shape_vars, body)]
735

Ian Lynagh's avatar
Ian Lynagh committed
736
    from_prod (IdRepr _)
737
              expr
Ian Lynagh's avatar
Ian Lynagh committed
738
              _shape_vars
739
              [repr_var]
Ian Lynagh's avatar
Ian Lynagh committed
740
              _res_ty
741
742
743
              body
      = return $ Let (NonRec repr_var expr) body

744
745
    from_prod (VoidRepr {})
              expr
Ian Lynagh's avatar
Ian Lynagh committed
746
              _shape_vars
747
              [repr_var]
Ian Lynagh's avatar
Ian Lynagh committed
748
              _res_ty
749
750
751
              body
      = return $ Let (NonRec repr_var expr) body

Ian Lynagh's avatar
Ian Lynagh committed
752
753
    from_prod _ _ _ _ _ _ = panic "buildFromArrPRepr/from_prod"

754
buildPRDictRepr :: Repr -> VM CoreExpr
755
756
buildPRDictRepr (VoidRepr { void_tycon = tycon })
  = prDFunOfTyCon tycon
757
buildPRDictRepr (IdRepr ty) = mkPR ty
758
buildPRDictRepr (ProdRepr {
759
760
                   prod_components = tys
                 , prod_tycon      = tycon
761
                 })
762
  = do
763
764
765
      prs  <- mapM mkPR tys
      dfun <- prDFunOfTyCon tycon
      return $ dfun `mkTyApps` tys `mkApps` prs
766

767
buildPRDictRepr (SumRepr {
768
769
                   sum_components = prods
                 , sum_tycon      = tycon })
770
  = do
771
772
773
      prs  <- mapM buildPRDictRepr prods
      dfun <- prDFunOfTyCon tycon
      return $ dfun `mkTyApps` map reprType prods `mkApps` prs
774

775
776
777
buildPRDictRepr (EnumRepr { enum_tycon = tycon })
  = prDFunOfTyCon tycon

778
buildPRDict :: Repr -> TyCon -> TyCon -> TyCon -> VM CoreExpr
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
buildPRDict repr vect_tc prepr_tc _
  = do
      dict  <- buildPRDictRepr repr

      pr_co <- mkBuiltinCo prTyCon
      let co = mkAppCoercion pr_co
             . mkSymCoercion
             $ mkTyConApp arg_co var_tys

      return $ mkCoerce co dict
  where
    var_tys = mkTyVarTys $ tyConTyVars vect_tc

    Just arg_co = tyConFamilyCoercion_maybe prepr_tc

rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
794
795
buildPArrayTyCon :: TyCon -> TyCon -> VM TyCon
buildPArrayTyCon orig_tc vect_tc = fixV $ \repr_tc ->
796
  do
797
798
    name'  <- cloneName mkPArrayTyConOcc orig_name
    rhs    <- buildPArrayTyConRhs orig_name vect_tc repr_tc
799
800
801
802
803
804
805
806
807
    parray <- builtin parrayTyCon

    liftDs $ buildAlgTyCon name'
                           tyvars
                           []          -- no stupid theta
                           rhs
                           rec_flag    -- FIXME: is this ok?
                           False       -- FIXME: no generics
                           False       -- not GADT syntax
808
                           (Just $ mk_fam_inst parray vect_tc)
809
  where
rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
810
    orig_name = tyConName orig_tc
811
812
    tyvars = tyConTyVars vect_tc
    rec_flag = boolToRecFlag (isRecursiveTyCon vect_tc)
813

814

815
816
buildPArrayTyConRhs :: Name -> TyCon -> TyCon -> VM AlgTyConRhs
buildPArrayTyConRhs orig_name vect_tc repr_tc
817
  = do
818
      data_con <- buildPArrayDataCon orig_name vect_tc repr_tc
819
      return $ DataTyCon { data_cons = [data_con], is_enum = False }
820

821
822
buildPArrayDataCon :: Name -> TyCon -> TyCon -> VM DataCon
buildPArrayDataCon orig_name vect_tc repr_tc
823
  = do
824
      dc_name  <- cloneName mkPArrayDataConOcc orig_name
825
      repr     <- mkRepr vect_tc
826

827
828
829
      shape_tys <- arrShapeTys repr
      repr_tys  <- arrReprTys  repr

rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
830
      let tys = shape_tys ++ repr_tys
831
832
833

      liftDs $ buildDataCon dc_name
                            False                  -- not infix
834
                            (map (const NotMarkedStrict) tys)
835
836
837
838
839
                            []                     -- no field labels
                            (tyConTyVars vect_tc)
                            []                     -- no existentials
                            []                     -- no eq spec
                            []                     -- no context
840
                            tys
841
                            repr_tc
842

843
844
845
846
mkPADFun :: TyCon -> VM Var
mkPADFun vect_tc
  = newExportedVar (mkPADFunOcc $ getOccName vect_tc) =<< paDFunType vect_tc

847
848
849
buildTyConBindings :: TyCon -> TyCon -> TyCon -> TyCon -> Var
                   -> VM [(Var, CoreExpr)]
buildTyConBindings orig_tc vect_tc prepr_tc arr_tc dfun
rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
850
  = do
851
      repr  <- mkRepr vect_tc
852
      vectDataConWorkers repr orig_tc vect_tc arr_tc
853
      dict <- buildPADict repr vect_tc prepr_tc arr_tc dfun
854
855
      binds <- takeHoisted
      return $ (dfun, dict) : binds
rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
856

857
858
859
860
861
862
863
864
vectDataConWorkers :: Repr -> TyCon -> TyCon -> TyCon
                   -> VM ()
vectDataConWorkers repr orig_tc vect_tc arr_tc
  = do
      bs <- sequence
          . zipWith3 def_worker  (tyConDataCons orig_tc) rep_tys
          $ zipWith4 mk_data_con (tyConDataCons vect_tc)
                                 rep_tys
rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
865
866
                                 (inits reprs)
                                 (tail $ tails reprs)
867
868
869
870
871
872
873
874
875
      mapM_ (uncurry hoistBinding) bs
  where
    tyvars   = tyConTyVars vect_tc
    var_tys  = mkTyVarTys tyvars
    ty_args  = map Type var_tys

    res_ty   = mkTyConApp vect_tc var_tys

    rep_tys  = map dataConRepArgTys $ tyConDataCons vect_tc
rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
876
    reprs    = splitSumRepr repr
877
878
879
880
881

    [arr_dc] = tyConDataCons arr_tc

    mk_data_con con tys pre post
      = liftM2 (,) (vect_data_con con)
rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
882
                   (lift_data_con tys pre post (mkDataConTag con))
883
884

    vect_data_con con = return $ mkConApp con ty_args
rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
885
    lift_data_con tys pre_reprs post_reprs tag
886
887
      = do
          len  <- builtin liftingContext
Ian Lynagh's avatar
Ian Lynagh committed
888
          args <- mapM (newLocalVar (fsLit "xs"))
889
                  =<< mapM mkPArrayType tys
rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
890

891
892
          shape <- replicateShape repr (Var len) tag
          repr  <- mk_arr_repr (Var len) (map Var args)
rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
893

rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
894
895
          pre   <- liftM concat $ mapM emptyArrRepr pre_reprs
          post  <- liftM concat $ mapM emptyArrRepr post_reprs
896
897
898
899
900
901
902
903
904
905
906

          return . mkLams (len : args)
                 . wrapFamInstBody arr_tc var_tys
                 . mkConApp arr_dc
                 $ ty_args ++ shape ++ pre ++ repr ++ post

    mk_arr_repr len []
      = do
          units <- replicatePA len (Var unitDataConId)
          return [units]

Ian Lynagh's avatar
Ian Lynagh committed
907
    mk_arr_repr _ arrs = return arrs
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922

    def_worker data_con arg_tys mk_body
      = do
          body <- closedV
                . inBind orig_worker
                . polyAbstract tyvars $ \abstract ->
                  liftM (abstract . vectorised)
                $ buildClosures tyvars [] arg_tys res_ty mk_body

          vect_worker <- cloneId mkVectOcc orig_worker (exprType body)
          defGlobalVar orig_worker vect_worker
          return (vect_worker, body)
      where
        orig_worker = dataConWorkId data_con

923
buildPADict :: Repr -> TyCon -> TyCon -> TyCon -> Var -> VM CoreExpr
Ian Lynagh's avatar
Ian Lynagh committed
924
buildPADict repr vect_tc prepr_tc arr_tc _
925
  = polyAbstract tvs $ \abstract ->
rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
926
    do
927
      meth_binds <- mapM (mk_method repr) paMethods
928
      let meth_exprs = map (Var . fst) meth_binds
rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
929

930
      pa_dc <- builtin paDataCon
rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
931
      let dict = mkConApp pa_dc (Type (mkTyConApp vect_tc arg_tys) : meth_exprs)
932
          body = Let (Rec meth_binds) dict
933
      return . mkInlineMe $ abstract body
rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
934
935
936
937
  where
    tvs = tyConTyVars arr_tc
    arg_tys = mkTyVarTys tvs

938
    mk_method repr (name, build)
rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
939
940
      = localV
      $ do
941
          body <- build repr vect_tc prepr_tc arr_tc
942
          var  <- newLocalVar name (exprType body)
rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
943
          return (var, mkInlineMe body)
944

Ian Lynagh's avatar
Ian Lynagh committed
945
paMethods :: [(FastString, Repr -> TyCon -> TyCon -> TyCon -> VM CoreExpr)]
Ian Lynagh's avatar
Ian Lynagh committed
946
947
948
949
950
paMethods = [(fsLit "toPRepr",      buildToPRepr),
             (fsLit "fromPRepr",    buildFromPRepr),
             (fsLit "toArrPRepr",   buildToArrPRepr),
             (fsLit "fromArrPRepr", buildFromArrPRepr),
             (fsLit "dictPRepr",    buildPRDict)]
rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
951

952
953
954
-- | Split the given tycons into two sets depending on whether they have to be
-- converted (first list) or not (second list). The first argument contains
-- information about the conversion status of external tycons:
955
--
956
957
958
959
960
961
962
--   * tycons which have converted versions are mapped to True
--   * tycons which are not changed by vectorisation are mapped to False
--   * tycons which can't be converted are not elements of the map
--
classifyTyCons :: UniqFM Bool -> [TyConGroup] -> ([TyCon], [TyCon])
classifyTyCons = classify [] []
  where
Ian Lynagh's avatar
Ian Lynagh committed
963
    classify conv keep _  [] = (conv, keep)
964
965
966
967
968
969
970
971
972
973
974
975
976
977
    classify conv keep cs ((tcs, ds) : rs)
      | can_convert && must_convert
        = classify (tcs ++ conv) keep (cs `addListToUFM` [(tc,True) | tc <- tcs]) rs
      | can_convert
        = classify conv (tcs ++ keep) (cs `addListToUFM` [(tc,False) | tc <- tcs]) rs
      | otherwise
        = classify conv keep cs rs
      where
        refs = ds `delListFromUniqSet` tcs

        can_convert  = isNullUFM (refs `minusUFM` cs) && all convertable tcs
        must_convert = foldUFM (||) False (intersectUFM_C const cs refs)

        convertable tc = isDataTyCon tc && all isVanillaDataCon (tyConDataCons tc)
978

979
980
981
-- | Compute mutually recursive groups of tycons in topological order
--
tyConGroups :: [TyCon] -> [TyConGroup]
982
tyConGroups tcs = map mk_grp (stronglyConnCompFromEdgedVertices edges)
983
984
985
986
987
988
989
990
991
992
  where
    edges = [((tc, ds), tc, uniqSetToList ds) | tc <- tcs
                                , let ds = tyConsOfTyCon tc]

    mk_grp (AcyclicSCC (tc, ds)) = ([tc], ds)
    mk_grp (CyclicSCC els)       = (tcs, unionManyUniqSets dss)
      where
        (tcs, dss) = unzip els

tyConsOfTyCon :: TyCon -> UniqSet TyCon
993
tyConsOfTyCon
994
995
996
997
998
  = tyConsOfTypes . concatMap dataConRepArgTys . tyConDataCons

tyConsOfType :: Type -> UniqSet TyCon
tyConsOfType ty
  | Just ty' <- coreView ty    = tyConsOfType ty'
Ian Lynagh's avatar
Ian Lynagh committed
999
tyConsOfType (TyVarTy _)       = emptyUniqSet
1000
1001
1002
1003
1004
1005
1006
tyConsOfType (TyConApp tc tys) = extend (tyConsOfTypes tys)
  where
    extend | isUnLiftedTyCon tc
           || isTupleTyCon   tc = id

           | otherwise          = (`addOneToUniqSet` tc)

1007
1008
1009
1010
1011
1012
1013
1014
1015
tyConsOfType (AppTy a b)       = tyConsOfType a `unionUniqSets` tyConsOfType b
tyConsOfType (FunTy a b)       = (tyConsOfType a `unionUniqSets` tyConsOfType b)
                                 `addOneToUniqSet` funTyCon
tyConsOfType (ForAllTy _ ty)   = tyConsOfType ty
tyConsOfType other             = pprPanic "ClosureConv.tyConsOfType" $ ppr other

tyConsOfTypes :: [Type] -> UniqSet TyCon
tyConsOfTypes = unionManyUniqSets . map tyConsOfType

1016
1017
1018
1019
1020
1021
1022
1023

-- ----------------------------------------------------------------------------
-- Conversions

fromVect :: Type -> CoreExpr -> VM CoreExpr
fromVect ty expr | Just ty' <- coreView ty = fromVect ty' expr
fromVect (FunTy arg_ty res_ty) expr
  = do
Ian Lynagh's avatar
Ian Lynagh committed
1024
      arg     <- newLocalVar (fsLit "x") arg_ty
1025
1026
1027
1028
1029
      varg    <- toVect arg_ty (Var arg)
      varg_ty <- vectType arg_ty
      vres_ty <- vectType res_ty
      apply   <- builtin applyClosureVar
      body    <- fromVect res_ty
1030
               $ Var apply `mkTyApps` [varg_ty, vres_ty] `mkApps` [expr, varg]
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
      return $ Lam arg body
fromVect ty expr
  = identityConv ty >> return expr

toVect :: Type -> CoreExpr -> VM CoreExpr
toVect ty expr = identityConv ty >> return expr

identityConv :: Type -> VM ()
identityConv ty | Just ty' <- coreView ty = identityConv ty'
identityConv (TyConApp tycon tys)
  = do
      mapM_ identityConv tys
      identityConvTyCon tycon
Ian Lynagh's avatar
Ian Lynagh committed
1044
identityConv _ = noV
1045
1046
1047
1048
1049

identityConvTyCon :: TyCon -> VM ()
identityConvTyCon tc
  | isBoxedTupleTyCon tc = return ()
  | isUnLiftedTyCon tc   = return ()
1050
1051
1052
  | otherwise            = do
                             tc' <- maybeV (lookupTyCon tc)
                             if tc == tc' then return () else noV
1053