From: Roman Leshchinskiy Date: Sat, 18 Dec 2010 11:49:53 +0000 (+0000) Subject: vectoriser: adapt to new superclass story part I (dictionary construction) X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=4837a66d2d6a8a6db09067a3cd8c9038a9027a2d vectoriser: adapt to new superclass story part I (dictionary construction) --- diff --git a/compiler/vectorise/Vectorise/Builtins/Base.hs b/compiler/vectorise/Vectorise/Builtins/Base.hs index 8e22070..5e4d47d 100644 --- a/compiler/vectorise/Vectorise/Builtins/Base.hs +++ b/compiler/vectorise/Vectorise/Builtins/Base.hs @@ -63,6 +63,7 @@ data Builtins , pdataTyCon :: TyCon -- ^ PData , paTyCon :: TyCon -- ^ PA , paDataCon :: DataCon -- ^ PA + , paPRSel :: Var -- ^ PA , preprTyCon :: TyCon -- ^ PRepr , prTyCon :: TyCon -- ^ PR , prDataCon :: DataCon -- ^ PR diff --git a/compiler/vectorise/Vectorise/Builtins/Initialise.hs b/compiler/vectorise/Vectorise/Builtins/Initialise.hs index 992a880..d9a1f0d 100644 --- a/compiler/vectorise/Vectorise/Builtins/Initialise.hs +++ b/compiler/vectorise/Vectorise/Builtins/Initialise.hs @@ -46,8 +46,10 @@ initBuiltins pkg let [parrayDataCon] = tyConDataCons parrayTyCon pdataTyCon <- externalTyCon dph_PArray (fsLit "PData") - paTyCon <- externalClassTyCon dph_PArray (fsLit "PA") - let [paDataCon] = tyConDataCons paTyCon + pa <- externalClass dph_PArray (fsLit "PA") + let paTyCon = classTyCon pa + [paDataCon] = tyConDataCons paTyCon + paPRSel = classSCSelId pa 0 preprTyCon <- externalTyCon dph_PArray (fsLit "PRepr") prTyCon <- externalClassTyCon dph_PArray (fsLit "PR") @@ -127,6 +129,7 @@ initBuiltins pkg , pdataTyCon = pdataTyCon , paTyCon = paTyCon , paDataCon = paDataCon + , paPRSel = paPRSel , preprTyCon = preprTyCon , prTyCon = prTyCon , prDataCon = prDataCon diff --git a/compiler/vectorise/Vectorise/Utils.hs b/compiler/vectorise/Vectorise/Utils.hs index 8f1d7db..e701383 100644 --- a/compiler/vectorise/Vectorise/Utils.hs +++ b/compiler/vectorise/Vectorise/Utils.hs @@ -146,8 +146,8 @@ zipScalars arg_tys res_ty scalarClosure :: [Type] -> Type -> CoreExpr -> CoreExpr -> VM CoreExpr scalarClosure arg_tys res_ty scalar_fun array_fun = do - ctr <- builtin (closureCtrFun $ length arg_tys) - Just pas <- liftM sequence $ mapM paDictOfType (init arg_tys) + ctr <- builtin (closureCtrFun $ length arg_tys) + pas <- mapM paDictOfType (init arg_tys) return $ Var ctr `mkTyApps` (arg_tys ++ [res_ty]) `mkApps` (pas ++ [scalar_fun, array_fun]) diff --git a/compiler/vectorise/Vectorise/Utils/Base.hs b/compiler/vectorise/Vectorise/Utils/Base.hs index 490eba6..0ffaa60 100644 --- a/compiler/vectorise/Vectorise/Utils/Base.hs +++ b/compiler/vectorise/Vectorise/Utils/Base.hs @@ -15,9 +15,11 @@ module Vectorise.Utils.Base ( mkPDataType, mkBuiltinCo, mkVScrut, - + + preprSynTyCon, pdataReprTyCon, pdataReprDataCon, + prDFunOfTyCon ) where import Vectorise.Monad @@ -35,6 +37,8 @@ import Literal import Outputable import FastString +import Control.Monad (liftM) + -- Simple Types --------------------------------------------------------------- voidType :: VM Type @@ -140,6 +144,9 @@ mkVScrut (ve, le) where ty = exprType ve +preprSynTyCon :: Type -> VM (TyCon, [Type]) +preprSynTyCon ty = builtin preprTyCon >>= (`lookupFamInst` [ty]) + pdataReprTyCon :: Type -> VM (TyCon, [Type]) pdataReprTyCon ty = builtin pdataTyCon >>= (`lookupFamInst` [ty]) @@ -151,4 +158,9 @@ pdataReprDataCon ty let [dc] = tyConDataCons tc return (dc, arg_tys) +prDFunOfTyCon :: TyCon -> VM CoreExpr +prDFunOfTyCon tycon + = liftM Var + . maybeCantVectoriseM "No PR dictionary for tycon" (ppr tycon) + $ lookupTyConPR tycon diff --git a/compiler/vectorise/Vectorise/Utils/Closure.hs b/compiler/vectorise/Vectorise/Utils/Closure.hs index 6b8688c..152c51d 100644 --- a/compiler/vectorise/Vectorise/Utils/Closure.hs +++ b/compiler/vectorise/Vectorise/Utils/Closure.hs @@ -38,9 +38,9 @@ mkClosure -> VM VExpr mkClosure arg_ty res_ty env_ty (vfn,lfn) (venv,lenv) - = do Just dict <- paDictOfType env_ty - mkv <- builtin closureVar - mkl <- builtin liftedClosureVar + = do dict <- paDictOfType env_ty + mkv <- builtin closureVar + mkl <- builtin liftedClosureVar return (Var mkv `mkTyApps` [arg_ty, res_ty, env_ty] `mkApps` [dict, vfn, lfn, venv], Var mkl `mkTyApps` [arg_ty, res_ty, env_ty] `mkApps` [dict, vfn, lfn, lenv]) diff --git a/compiler/vectorise/Vectorise/Utils/PADict.hs b/compiler/vectorise/Vectorise/Utils/PADict.hs index 30937b1..d9a00b9 100644 --- a/compiler/vectorise/Vectorise/Utils/PADict.hs +++ b/compiler/vectorise/Vectorise/Utils/PADict.hs @@ -4,7 +4,6 @@ module Vectorise.Utils.PADict ( paDictArgType, paDictOfType, paDFunType, - paDFunApply, paMethod ) where @@ -13,6 +12,8 @@ import Vectorise.Builtins import Vectorise.Utils.Base import CoreSyn +import CoreUtils +import Coercion import Type import TypeRep import TyCon @@ -47,36 +48,37 @@ paDictArgType tv = go (TyVarTy tv) (tyVarKind tv) go _ _ = return Nothing --- | Get the PA dictionary for some type, or `Nothing` if there isn't one. -paDictOfType :: Type -> VM (Maybe CoreExpr) +-- | Get the PA dictionary for some type +paDictOfType :: Type -> VM CoreExpr paDictOfType ty = paDictOfTyApp ty_fn ty_args where (ty_fn, ty_args) = splitAppTys ty - paDictOfTyApp :: Type -> [Type] -> VM (Maybe CoreExpr) + paDictOfTyApp :: Type -> [Type] -> VM CoreExpr paDictOfTyApp ty_fn ty_args | Just ty_fn' <- coreView ty_fn = paDictOfTyApp ty_fn' ty_args + -- for type variables, look up the dfun and apply to the PA dictionaries + -- of the type arguments paDictOfTyApp (TyVarTy tv) ty_args = do dfun <- maybeV (lookupTyVarPA tv) - liftM Just $ paDFunApply dfun ty_args + dicts <- mapM paDictOfType ty_args + return $ dfun `mkTyApps` ty_args `mkApps` dicts - paDictOfTyApp (TyConApp tc _) ty_args - = do mdfun <- lookupTyConPA tc - case mdfun of - Nothing - -> pprTrace "VectUtils.paDictOfType" - (vcat [ text "No PA dictionary" - , text "for tycon: " <> ppr tc - , text "in type: " <> ppr ty]) - $ return Nothing + -- for tycons, we also need to apply the dfun to the PR dictionary of + -- the representation type + paDictOfTyApp (TyConApp tc []) ty_args + = do + dfun <- maybeV $ lookupTyConPA tc + pr <- prDictOfPRepr tc ty_args + dicts <- mapM paDictOfType ty_args + return $ Var dfun `mkTyApps` ty_args `mkApps` (pr:dicts) - Just dfun -> liftM Just $ paDFunApply (Var dfun) ty_args + paDictOfTyApp _ _ = failure - paDictOfTyApp ty _ - = cantVectorise "Can't construct PA dictionary for type" (ppr ty) + failure = cantVectorise "Can't construct PA dictionary for type" (ppr ty) @@ -91,12 +93,6 @@ paDFunType tc tvs = tyConTyVars tc arg_tys = mkTyVarTys tvs -paDFunApply :: CoreExpr -> [Type] -> VM CoreExpr -paDFunApply dfun tys - = do Just dicts <- liftM sequence $ mapM paDictOfType tys - return $ mkApps (mkTyApps dfun tys) dicts - - paMethod :: (Builtins -> Var) -> String -> Type -> VM CoreExpr paMethod _ name ty | Just tycon <- splitPrimTyCon ty @@ -106,7 +102,84 @@ paMethod _ name ty paMethod method _ ty = do - fn <- builtin method - Just dict <- paDictOfType ty + fn <- builtin method + dict <- paDictOfType ty return $ mkApps (Var fn) [Type ty, dict] +-- | Get the PR (PRepr t) dictionary, where t is the tycon applied to the type +-- arguments +prDictOfPRepr :: TyCon -> [Type] -> VM CoreExpr +prDictOfPRepr tycon tys + = do + (prepr_tc, prepr_args) <- preprSynTyCon (mkTyConApp tycon tys) + case coreView (mkTyConApp prepr_tc prepr_args) of + Just rhs -> do + dict <- prDictOfReprType rhs + pr_co <- mkBuiltinCo prTyCon + let Just arg_co = tyConFamilyCoercion_maybe prepr_tc + let co = mkAppCoercion pr_co + $ mkSymCoercion + $ mkTyConApp arg_co prepr_args + return $ mkCoerce co dict + Nothing -> cantVectorise "Invalid PRepr type instance" + $ ppr $ mkTyConApp prepr_tc prepr_args + +-- | Get the PR dictionary for a type. The argument must be a representation +-- type. +prDictOfReprType :: Type -> VM CoreExpr +prDictOfReprType ty + | Just (tycon, tyargs) <- splitTyConApp_maybe ty + = do + -- a representation tycon must have a PR instance + dfun <- maybeV $ lookupTyConPR tycon + prDFunApply dfun tyargs + + | otherwise + = do + -- it is a tyvar or an application of a tyvar + -- determine the PR dictionary from its PA dictionary + -- + -- NOTE: This assumes that PRepr t ~ t is for all representation types + -- t + -- + -- FIXME: This doesn't work for kinds other than * at the moment. We'd + -- have to simply abstract the term over the missing type arguments. + pa <- paDictOfType ty + prsel <- builtin paPRSel + return $ Var prsel `mkApps` [Type ty, pa] + +-- | Apply a tycon's PR dfun to dictionary arguments (PR or PA) corresponding +-- to the argument types. +prDFunApply :: Var -> [Type] -> VM CoreExpr +prDFunApply dfun tys + | Just [] <- ctxs -- PR (a :-> b) doesn't have a context + = return $ Var dfun `mkTyApps` tys + + | Just tycons <- ctxs + , length tycons == length tys + = do + pa <- builtin paTyCon + pr <- builtin prTyCon + args <- zipWithM (dictionary pa pr) tys tycons + return $ Var dfun `mkTyApps` tys `mkApps` args + + | otherwise = invalid + where + -- the dfun's contexts - if its type is (PA a, PR b) => PR (C a b) then + -- ctxs is Just [PA, PR] + ctxs = fmap (map fst) + $ sequence + $ map splitTyConApp_maybe + $ fst + $ splitFunTys + $ snd + $ splitForAllTys + $ varType dfun + + dictionary pa pr ty tycon + | tycon == pa = paDictOfType ty + | tycon == pr = prDictOfReprType ty + | otherwise = invalid + + invalid = cantVectorise "Invalid PR dfun type" (ppr (varType dfun) <+> ppr tys) + diff --git a/compiler/vectorise/Vectorise/Utils/PRDict.hs b/compiler/vectorise/Vectorise/Utils/PRDict.hs index e573232..0c5451b 100644 --- a/compiler/vectorise/Vectorise/Utils/PRDict.hs +++ b/compiler/vectorise/Vectorise/Utils/PRDict.hs @@ -2,13 +2,12 @@ module Vectorise.Utils.PRDict ( prDFunOfTyCon, prDictOfType, - prDictOfTyApp, - prDFunApply, wrapPR ) where import Vectorise.Monad import Vectorise.Builtins +import Vectorise.Utils.Base import Vectorise.Utils.PADict import CoreSyn @@ -19,14 +18,6 @@ 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 @@ -50,6 +41,6 @@ prDFunApply dfun tys wrapPR :: Type -> VM CoreExpr wrapPR ty = do - Just pa_dict <- paDictOfType ty - pr_dfun <- prDFunOfTyCon =<< builtin wrapTyCon + pa_dict <- paDictOfType ty + pr_dfun <- prDFunOfTyCon =<< builtin wrapTyCon return $ mkApps pr_dfun [Type ty, pa_dict] diff --git a/compiler/vectorise/Vectorise/Utils/Poly.hs b/compiler/vectorise/Vectorise/Utils/Poly.hs index 04237f8..8856afd 100644 --- a/compiler/vectorise/Vectorise/Utils/Poly.hs +++ b/compiler/vectorise/Vectorise/Utils/Poly.hs @@ -43,11 +43,11 @@ polyArity tvs = do polyApply :: CoreExpr -> [Type] -> VM CoreExpr polyApply expr tys - = do Just dicts <- liftM sequence $ mapM paDictOfType tys + = do dicts <- mapM paDictOfType tys return $ expr `mkTyApps` tys `mkApps` dicts polyVApply :: VExpr -> [Type] -> VM VExpr polyVApply expr tys - = do Just dicts <- liftM sequence $ mapM paDictOfType tys + = do dicts <- mapM paDictOfType tys return $ mapVect (\e -> e `mkTyApps` tys `mkApps` dicts) expr