compiler/vectorise/Vectorise/Utils/PRDict.hs

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