Break out type vectorisation into own module

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

diff --git a/compiler/vectorise/VectType.hs b/compiler/vectorise/VectType.hs
index 0004def..e47058b 100644 (file)
--- 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