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