Simplify generation of PR dictionaries for products

[ghc-hetmet.git] / compiler / vectorise / VectUtils.hs

diff --git a/compiler/vectorise/VectUtils.hs b/compiler/vectorise/VectUtils.hs
index 77e037f..a50b4de 100644 (file)
--- a/compiler/vectorise/VectUtils.hs
+++ b/compiler/vectorise/VectUtils.hs
@@ -4,14 +4,12 @@ module VectUtils (
   mkDataConTag,
   splitClosureTy,
 
-  TyConRepr(..), mkTyConRepr,
-  mkToArrPRepr, mkFromArrPRepr,
   mkPADictType, mkPArrayType, mkPReprType,
 
   parrayCoerce, parrayReprTyCon, parrayReprDataCon, mkVScrut,
-  prDictOfType, prCoerce,
+  prDFunOfTyCon, prCoerce,
   paDictArgType, paDictOfType, paDFunType,
-  paMethod, lengthPA, replicatePA, emptyPA, liftPA,
+  paMethod, mkPR, lengthPA, replicatePA, emptyPA, liftPA,
   polyAbstract, polyApply, polyVApply,
   hoistBinding, hoistExpr, hoistPolyVExpr, takeHoisted,
   buildClosure, buildClosures,
@@ -37,6 +35,7 @@ import MkId               ( unwrapFamInstScrut )
 import Name               ( Name )
 import PrelNames
 import TysWiredIn
+import TysPrim            ( intPrimTy )
 import BasicTypes         ( Boxity(..) )
 
 import Outputable
@@ -125,80 +124,6 @@ mkBuiltinTyConApps1 get_tc dft tys
   where
     mk tc ty1 ty2 = mkTyConApp tc [ty1,ty2]
 
-data TyConRepr = TyConRepr {
-                   repr_tyvars      :: [TyVar]
-                 , repr_tys         :: [[Type]]
-
-                 , repr_prod_tycons :: [Maybe TyCon]
-                 , repr_prod_tys    :: [Type]
-                 , repr_sum_tycon   :: Maybe TyCon
-                 , repr_type        :: Type
-                 }
-
-mkTyConRepr :: TyCon -> VM TyConRepr
-mkTyConRepr vect_tc
-  = do
-      prod_tycons <- mapM (mk_tycon prodTyCon) rep_tys
-      let prod_tys = zipWith mk_tc_app_maybe prod_tycons rep_tys
-      sum_tycon   <- mk_tycon sumTyCon prod_tys
-
-      return $ TyConRepr {
-                 repr_tyvars      = tyvars
-               , repr_tys         = rep_tys
-
-               , repr_prod_tycons = prod_tycons
-               , repr_prod_tys    = prod_tys
-               , repr_sum_tycon   = sum_tycon
-               , repr_type        = mk_tc_app_maybe sum_tycon prod_tys
-               }
-  where
-    tyvars = tyConTyVars vect_tc
-    data_cons = tyConDataCons vect_tc
-    rep_tys   = map dataConRepArgTys data_cons
-
-    mk_tycon get_tc tys
-      | n > 1     = builtin (Just . get_tc n)
-      | otherwise = return Nothing
-      where n = length tys
-
-    mk_tc_app_maybe Nothing   []   = unitTy
-    mk_tc_app_maybe Nothing   [ty] = ty
-    mk_tc_app_maybe (Just tc) tys  = mkTyConApp tc tys
-
-mkToArrPRepr :: CoreExpr -> CoreExpr -> [[CoreExpr]] -> VM CoreExpr
-mkToArrPRepr len sel ess
-  = do
-      let mk_sum [(expr, ty)] = return (expr, ty)
-          mk_sum es
-            = do
-                sum_tc <- builtin . sumTyCon $ length es
-                (sum_rtc, _) <- parrayReprTyCon (mkTyConApp sum_tc tys)
-                let [sum_rdc] = tyConDataCons sum_rtc
-
-                return (mkConApp sum_rdc (map Type tys ++ (len : sel : exprs)),
-                        mkTyConApp sum_tc tys)
-            where
-              (exprs, tys) = unzip es
-
-          mk_prod [expr] = return (expr, splitPArrayTy (exprType expr))
-          mk_prod exprs
-            = do
-                prod_tc <- builtin . prodTyCon $ length exprs
-                (prod_rtc, _) <- parrayReprTyCon (mkTyConApp prod_tc tys)
-                let [prod_rdc] = tyConDataCons prod_rtc
-
-                return (mkConApp prod_rdc (map Type tys ++ (len : exprs)),
-                        mkTyConApp prod_tc tys)
-            where
-              tys = map (splitPArrayTy . exprType) exprs
-
-      liftM fst (mk_sum =<< mapM mk_prod ess)
-
-mkFromArrPRepr :: CoreExpr -> Type -> Var -> Var -> [[Var]] -> CoreExpr
-               -> VM CoreExpr
-mkFromArrPRepr scrut res_ty len sel vars res
-  = return (Var unitDataConId)
-
 mkClosureType :: Type -> Type -> VM Type
 mkClosureType arg_ty res_ty = mkBuiltinTyConApp closureTyCon [arg_ty, res_ty]
 
@@ -241,35 +166,9 @@ mkVScrut (ve, le)
       (tc, arg_tys) <- parrayReprTyCon (exprType ve)
       return ((ve, unwrapFamInstScrut tc arg_tys le), tc, arg_tys)
 
-prDictOfType :: Type -> VM CoreExpr
-prDictOfType orig_ty
-  | Just (tycon, ty_args) <- splitTyConApp_maybe orig_ty
-  = do
-      dfun <- traceMaybeV "prDictOfType" (ppr tycon) (lookupTyConPR tycon)
-      prDFunApply (Var dfun) ty_args
-
-prDFunApply :: CoreExpr -> [Type] -> VM CoreExpr
-prDFunApply dfun tys
-  = do
-      args <- mapM mkDFunArg arg_tys
-      return $ mkApps mono_dfun args
-  where
-    mono_dfun    = mkTyApps dfun tys
-    (arg_tys, _) = splitFunTys (exprType mono_dfun)
-
-mkDFunArg :: Type -> VM CoreExpr
-mkDFunArg ty
-  | Just (tycon, [arg]) <- splitTyConApp_maybe ty
-
-  = let name = tyConName tycon
-
-        get_dict | name == paTyConName = paDictOfType
-                 | name == prTyConName = prDictOfType
-                 | otherwise           = pprPanic "mkDFunArg" (ppr ty)
-
-    in get_dict arg
-
-mkDFunArg ty = pprPanic "mkDFunArg" (ppr ty)
+prDFunOfTyCon :: TyCon -> VM CoreExpr
+prDFunOfTyCon tycon
+  = liftM Var (traceMaybeV "prDictOfTyCon" (ppr tycon) (lookupTyConPR tycon))
 
 prCoerce :: TyCon -> [Type] -> CoreExpr -> VM CoreExpr
 prCoerce repr_tc args expr