compiler/vectorise/Vectorise/Utils/PRDict.hs

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