Break out type vectorisation into own module

2 files changed, 119 insertions, 98 deletions

diff --git a/compiler/vectorise/VectType.hs b/compiler/vectorise/VectType.hs
index 0004defeba..e47058b505 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 0000000000..00df5d50be
--- /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
+
+