Finish breaking up vectoriser utils

[ghc-hetmet.git] / compiler / vectorise / Vectorise / Utils / PRDict.hs

diff --git a/compiler/vectorise/Vectorise/Utils/PRDict.hs b/compiler/vectorise/Vectorise/Utils/PRDict.hs
new file mode 100644 (file)
index 0000000..e573232
--- /dev/null
+++ b/compiler/vectorise/Vectorise/Utils/PRDict.hs
@@ -0,0 +1,55 @@
+
+module Vectorise.Utils.PRDict (
+       prDFunOfTyCon,
+       prDictOfType,
+       prDictOfTyApp,
+       prDFunApply,
+       wrapPR
+)
+where
+import Vectorise.Monad
+import Vectorise.Builtins
+import Vectorise.Utils.PADict
+
+import CoreSyn
+import Type
+import TypeRep
+import TyCon
+import Outputable
+import Control.Monad
+
+
+prDFunOfTyCon :: TyCon -> VM CoreExpr
+prDFunOfTyCon tycon
+  = liftM Var
+  . maybeCantVectoriseM "No PR dictionary for tycon" (ppr tycon)
+  $ lookupTyConPR tycon
+
+
+
+prDictOfType :: Type -> VM CoreExpr
+prDictOfType ty = prDictOfTyApp ty_fn ty_args
+  where
+    (ty_fn, ty_args) = splitAppTys ty
+
+prDictOfTyApp :: Type -> [Type] -> VM CoreExpr
+prDictOfTyApp ty_fn ty_args
+  | Just ty_fn' <- coreView ty_fn = prDictOfTyApp ty_fn' ty_args
+prDictOfTyApp (TyConApp tc _) ty_args
+  = do
+      dfun <- liftM Var $ maybeV (lookupTyConPR tc)
+      prDFunApply dfun ty_args
+prDictOfTyApp _ _ = noV
+
+prDFunApply :: CoreExpr -> [Type] -> VM CoreExpr
+prDFunApply dfun tys
+  = do
+      dicts <- mapM prDictOfType tys
+      return $ mkApps (mkTyApps dfun tys) dicts
+
+wrapPR :: Type -> VM CoreExpr
+wrapPR ty
+  = do
+      Just  pa_dict <- paDictOfType ty
+      pr_dfun       <- prDFunOfTyCon =<< builtin wrapTyCon
+      return $ mkApps pr_dfun [Type ty, pa_dict]