compiler/vectorise/Vectorise/Utils/PRDict.hs

   1
   2 module Vectorise.Utils.PRDict (
   3         prDFunOfTyCon,
   4         prDictOfType,
   5         prDictOfTyApp,
   6         prDFunApply,
   7         wrapPR
   8 )
   9 where
  10 import Vectorise.Monad
  11 import Vectorise.Builtins
  12 import Vectorise.Utils.PADict
  13
  14 import CoreSyn
  15 import Type
  16 import TypeRep
  17 import TyCon
  18 import Outputable
  19 import Control.Monad
  20
  21
  22 prDFunOfTyCon :: TyCon -> VM CoreExpr
  23 prDFunOfTyCon tycon
  24   = liftM Var
  25   . maybeCantVectoriseM "No PR dictionary for tycon" (ppr tycon)
  26   $ lookupTyConPR tycon
  27
  28
  29
  30 prDictOfType :: Type -> VM CoreExpr
  31 prDictOfType ty = prDictOfTyApp ty_fn ty_args
  32   where
  33     (ty_fn, ty_args) = splitAppTys ty
  34
  35 prDictOfTyApp :: Type -> [Type] -> VM CoreExpr
  36 prDictOfTyApp ty_fn ty_args
  37   | Just ty_fn' <- coreView ty_fn = prDictOfTyApp ty_fn' ty_args
  38 prDictOfTyApp (TyConApp tc _) ty_args
  39   = do
  40       dfun <- liftM Var $ maybeV (lookupTyConPR tc)
  41       prDFunApply dfun ty_args
  42 prDictOfTyApp _ _ = noV
  43
  44 prDFunApply :: CoreExpr -> [Type] -> VM CoreExpr
  45 prDFunApply dfun tys
  46   = do
  47       dicts <- mapM prDictOfType tys
  48       return $ mkApps (mkTyApps dfun tys) dicts
  49
  50 wrapPR :: Type -> VM CoreExpr
  51 wrapPR ty
  52   = do
  53       Just  pa_dict <- paDictOfType ty
  54       pr_dfun       <- prDFunOfTyCon =<< builtin wrapTyCon
  55       return $ mkApps pr_dfun [Type ty, pa_dict]