compiler/vectorise/Vectorise/Utils/Base.hs

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