From 099ead5c6163eb36d49d2883326128111b592825 Mon Sep 17 00:00:00 2001 From: "benl@ouroborus.net" Date: Tue, 7 Sep 2010 11:03:11 +0000 Subject: [PATCH] Break out type vectorisation into own module --- compiler/ghc.cabal.in | 1 + compiler/vectorise/VectType.hs | 100 +----------------------- compiler/vectorise/Vectorise/Type/Type.hs | 117 +++++++++++++++++++++++++++++ 3 files changed, 120 insertions(+), 98 deletions(-) create mode 100644 compiler/vectorise/Vectorise/Type/Type.hs diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index c9b219f..b4ab55c 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -459,6 +459,7 @@ Library VectVar Vectorise.Env Vectorise.Vect + Vectorise.Type.Type Vectorise.Builtins.Base Vectorise.Builtins.Initialise Vectorise.Builtins.Modules diff --git a/compiler/vectorise/VectType.hs b/compiler/vectorise/VectType.hs index 0004def..e47058b 100644 --- a/compiler/vectorise/VectType.hs +++ b/compiler/vectorise/VectType.hs @@ -11,6 +11,7 @@ import Vectorise.Env import Vectorise.Vect import Vectorise.Monad import Vectorise.Builtins +import Vectorise.Type.Type import HscTypes ( TypeEnv, extendTypeEnvList, typeEnvTyCons ) import BasicTypes @@ -29,7 +30,7 @@ import FamInstEnv ( FamInst, mkLocalFamInst ) import OccName import Id import MkId -import Var ( Var, TyVar, varType, varName ) +import Var import Name ( Name, getOccName ) import NameEnv @@ -45,7 +46,6 @@ import FastString import MonadUtils ( zipWith3M, foldrM, concatMapM ) import Control.Monad ( liftM, liftM2, zipWithM, zipWithM_, mapAndUnzipM ) import Data.List -import Data.Maybe debug = False dtrace s x = if debug then pprTrace "VectType" s x else x @@ -53,102 +53,6 @@ dtrace s x = if debug then pprTrace "VectType" s x else x -- ---------------------------------------------------------------------------- -- Types --- | Vectorise a type constructor. -vectTyCon :: TyCon -> VM TyCon -vectTyCon tc - | isFunTyCon tc = builtin closureTyCon - | isBoxedTupleTyCon tc = return tc - | isUnLiftedTyCon tc = return tc - | otherwise - = maybeCantVectoriseM "Tycon not vectorised: " (ppr tc) - $ lookupTyCon tc - - -vectAndLiftType :: Type -> VM (Type, Type) -vectAndLiftType ty | Just ty' <- coreView ty = vectAndLiftType ty' -vectAndLiftType ty - = do - mdicts <- mapM paDictArgType tyvars - let dicts = [dict | Just dict <- mdicts] - vmono_ty <- vectType mono_ty - lmono_ty <- mkPDataType vmono_ty - return (abstractType tyvars dicts vmono_ty, - abstractType tyvars dicts lmono_ty) - where - (tyvars, mono_ty) = splitForAllTys ty - - --- | Vectorise a type. -vectType :: Type -> VM Type -vectType ty - | Just ty' <- coreView ty - = vectType ty' - -vectType (TyVarTy tv) = return $ TyVarTy tv -vectType (AppTy ty1 ty2) = liftM2 AppTy (vectType ty1) (vectType ty2) -vectType (TyConApp tc tys) = liftM2 TyConApp (vectTyCon tc) (mapM vectType tys) -vectType (FunTy ty1 ty2) = liftM2 TyConApp (builtin closureTyCon) - (mapM vectAndBoxType [ty1,ty2]) - --- For each quantified var we need to add a PA dictionary out the front of the type. --- So forall a. C a => a -> a --- turns into forall a. Cv a => PA a => a :-> a -vectType ty@(ForAllTy _ _) - = do - -- split the type into the quantified vars, its dictionaries and the body. - let (tyvars, tyBody) = splitForAllTys ty - let (tyArgs, tyResult) = splitFunTys tyBody - - let (tyArgs_dict, tyArgs_regular) - = partition isDictType tyArgs - - -- vectorise the body. - let tyBody' = mkFunTys tyArgs_regular tyResult - tyBody'' <- vectType tyBody' - - -- vectorise the dictionary parameters. - dictsVect <- mapM vectType tyArgs_dict - - -- make a PA dictionary for each of the type variables. - dictsPA <- liftM catMaybes $ mapM paDictArgType tyvars - - -- pack it all back together. - return $ abstractType tyvars (dictsVect ++ dictsPA) tyBody'' - -vectType ty = cantVectorise "Can't vectorise type" (ppr ty) - - --- | Add quantified vars and dictionary parameters to the front of a type. -abstractType :: [TyVar] -> [Type] -> Type -> Type -abstractType tyvars dicts = mkForAllTys tyvars . mkFunTys dicts - - --- | Check if some type is a type class dictionary. -isDictType :: Type -> Bool -isDictType ty - = case splitTyConApp_maybe ty of - Just (tyCon, _) -> isClassTyCon tyCon - _ -> False - - --- ---------------------------------------------------------------------------- --- Boxing - -boxType :: Type -> VM Type -boxType ty - | Just (tycon, []) <- splitTyConApp_maybe ty - , isUnLiftedTyCon tycon - = do - r <- lookupBoxedTyCon tycon - case r of - Just tycon' -> return $ mkTyConApp tycon' [] - Nothing -> return ty - -boxType ty = return ty - -vectAndBoxType :: Type -> VM Type -vectAndBoxType ty = vectType ty >>= boxType - -- ---------------------------------------------------------------------------- -- Type definitions diff --git a/compiler/vectorise/Vectorise/Type/Type.hs b/compiler/vectorise/Vectorise/Type/Type.hs new file mode 100644 index 0000000..00df5d5 --- /dev/null +++ b/compiler/vectorise/Vectorise/Type/Type.hs @@ -0,0 +1,117 @@ + +module Vectorise.Type.Type + ( vectTyCon + , vectAndLiftType + , vectType) +where +import VectUtils +import Vectorise.Monad +import Vectorise.Builtins +import TypeRep +import Type +import TyCon +import Var +import Outputable +import Control.Monad +import Data.List +import Data.Maybe + + +-- | Vectorise a type constructor. +vectTyCon :: TyCon -> VM TyCon +vectTyCon tc + | isFunTyCon tc = builtin closureTyCon + | isBoxedTupleTyCon tc = return tc + | isUnLiftedTyCon tc = return tc + | otherwise + = maybeCantVectoriseM "Tycon not vectorised: " (ppr tc) + $ lookupTyCon tc + + +-- | Produce the vectorised and lifted versions of a type. +vectAndLiftType :: Type -> VM (Type, Type) +vectAndLiftType ty | Just ty' <- coreView ty = vectAndLiftType ty' +vectAndLiftType ty + = do + mdicts <- mapM paDictArgType tyvars + let dicts = [dict | Just dict <- mdicts] + vmono_ty <- vectType mono_ty + lmono_ty <- mkPDataType vmono_ty + return (abstractType tyvars dicts vmono_ty, + abstractType tyvars dicts lmono_ty) + where + (tyvars, mono_ty) = splitForAllTys ty + + +-- | Vectorise a type. +vectType :: Type -> VM Type +vectType ty + | Just ty' <- coreView ty + = vectType ty' + +vectType (TyVarTy tv) = return $ TyVarTy tv +vectType (AppTy ty1 ty2) = liftM2 AppTy (vectType ty1) (vectType ty2) +vectType (TyConApp tc tys) = liftM2 TyConApp (vectTyCon tc) (mapM vectType tys) +vectType (FunTy ty1 ty2) = liftM2 TyConApp (builtin closureTyCon) + (mapM vectAndBoxType [ty1,ty2]) + +-- For each quantified var we need to add a PA dictionary out the front of the type. +-- So forall a. C a => a -> a +-- turns into forall a. Cv a => PA a => a :-> a +vectType ty@(ForAllTy _ _) + = do + -- split the type into the quantified vars, its dictionaries and the body. + let (tyvars, tyBody) = splitForAllTys ty + let (tyArgs, tyResult) = splitFunTys tyBody + + let (tyArgs_dict, tyArgs_regular) + = partition isDictType tyArgs + + -- vectorise the body. + let tyBody' = mkFunTys tyArgs_regular tyResult + tyBody'' <- vectType tyBody' + + -- vectorise the dictionary parameters. + dictsVect <- mapM vectType tyArgs_dict + + -- make a PA dictionary for each of the type variables. + dictsPA <- liftM catMaybes $ mapM paDictArgType tyvars + + -- pack it all back together. + return $ abstractType tyvars (dictsVect ++ dictsPA) tyBody'' + +vectType ty = cantVectorise "Can't vectorise type" (ppr ty) + + +-- | Add quantified vars and dictionary parameters to the front of a type. +abstractType :: [TyVar] -> [Type] -> Type -> Type +abstractType tyvars dicts = mkForAllTys tyvars . mkFunTys dicts + + +-- | Check if some type is a type class dictionary. +isDictType :: Type -> Bool +isDictType ty + = case splitTyConApp_maybe ty of + Just (tyCon, _) -> isClassTyCon tyCon + _ -> False + + +-- | Create the boxed version of a vectorised type. +vectAndBoxType :: Type -> VM Type +vectAndBoxType ty = vectType ty >>= boxType + + +-- | Create the boxed version of a type. +boxType :: Type -> VM Type +boxType ty + | Just (tycon, []) <- splitTyConApp_maybe ty + , isUnLiftedTyCon tycon + = do + r <- lookupBoxedTyCon tycon + case r of + Just tycon' -> return $ mkTyConApp tycon' [] + Nothing -> return ty + + | otherwise = return ty + + -- 1.7.10.4