compiler/vectorise/Vectorise/Type/PRDict.hs

   1
   2 module Vectorise.Type.PRDict
   3         (buildPRDict)
   4 where
   5 import Vectorise.Utils
   6 import Vectorise.Monad
   7 import Vectorise.Builtins
   8 import Vectorise.Type.Repr
   9 import CoreSyn
  10 import CoreUtils
  11 import TyCon
  12 import Type
  13 import Coercion
  14
  15
  16
  17 buildPRDict :: TyCon -> TyCon -> TyCon -> SumRepr -> VM CoreExpr
  18 buildPRDict vect_tc prepr_tc _ r
  19   = do
  20       dict <- sum_dict r
  21       pr_co <- mkBuiltinCo prTyCon
  22       let co = mkAppCoercion pr_co
  23              . mkSymCoercion
  24              $ mkTyConApp arg_co ty_args
  25       return (mkCoerce co dict)
  26   where
  27     ty_args = mkTyVarTys (tyConTyVars vect_tc)
  28     Just arg_co = tyConFamilyCoercion_maybe prepr_tc
  29
  30     sum_dict EmptySum = prDFunOfTyCon =<< builtin voidTyCon
  31     sum_dict (UnarySum r) = con_dict r
  32     sum_dict (Sum { repr_sum_tc  = sum_tc
  33                   , repr_con_tys = tys
  34                   , repr_cons    = cons
  35                   })
  36       = do
  37           dicts <- mapM con_dict cons
  38           dfun  <- prDFunOfTyCon sum_tc
  39           return $ dfun `mkTyApps` tys `mkApps` dicts
  40
  41     con_dict (ConRepr _ r) = prod_dict r
  42
  43     prod_dict EmptyProd = prDFunOfTyCon =<< builtin voidTyCon
  44     prod_dict (UnaryProd r) = comp_dict r
  45     prod_dict (Prod { repr_tup_tc   = tup_tc
  46                     , repr_comp_tys = tys
  47                     , repr_comps    = comps })
  48       = do
  49           dicts <- mapM comp_dict comps
  50           dfun <- prDFunOfTyCon tup_tc
  51           return $ dfun `mkTyApps` tys `mkApps` dicts
  52
  53     comp_dict (Keep _ pr) = return pr
  54     comp_dict (Wrap ty)   = wrapPR ty
  55
  56