import Vectorise.Vect
import Vectorise.Monad
import Vectorise.Builtins
+import Vectorise.Type.Type
import HscTypes ( TypeEnv, extendTypeEnvList, typeEnvTyCons )
import BasicTypes
import OccName
import Id
import MkId
-import Var ( Var, TyVar, varType, varName )
+import Var
import Name ( Name, getOccName )
import NameEnv
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
-- ----------------------------------------------------------------------------
-- 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
--- /dev/null
+
+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
+
+
projects / ghc-hetmet.git / commitdiff