From df62b50deaadeab84a89b20b277dd4707f90c724 Mon Sep 17 00:00:00 2001
From: Roman Leshchinskiy <rl@cse.unsw.edu.au>
Date: Tue, 17 Jul 2007 04:16:45 +0000
Subject: [PATCH] Move type vectorisation code to a separate module

---
 compiler/package.conf.in        |    1 +
 compiler/vectorise/VectType.hs  |   46 +++++++++++++++++++++++++++++++++++++++
 compiler/vectorise/Vectorise.hs |   36 +++---------------------------
 3 files changed, 50 insertions(+), 33 deletions(-)
 create mode 100644 compiler/vectorise/VectType.hs

diff --git a/compiler/package.conf.in b/compiler/package.conf.in
index 24e9d72..6b33e08 100644
--- a/compiler/package.conf.in
+++ b/compiler/package.conf.in
@@ -260,6 +260,7 @@ exposed-modules:
 	VarEnv
 	VarSet
         VectMonad
+        VectType
         VectUtils
         Vectorise
 	WorkWrap
diff --git a/compiler/vectorise/VectType.hs b/compiler/vectorise/VectType.hs
new file mode 100644
index 0000000..155f420
--- /dev/null
+++ b/compiler/vectorise/VectType.hs
@@ -0,0 +1,46 @@
+module VectType ( vectTyCon, vectType )
+where
+
+#include "HsVersions.h"
+
+import VectMonad
+import VectUtils
+
+import TyCon
+import Type
+import TypeRep
+
+import Outputable
+
+import Control.Monad  ( liftM2 )
+
+vectTyCon :: TyCon -> VM TyCon
+vectTyCon tc
+  | isFunTyCon tc        = builtin closureTyCon
+  | isBoxedTupleTyCon tc = return tc
+  | isUnLiftedTyCon tc   = return tc
+  | otherwise = do
+                  r <- lookupTyCon tc
+                  case r of
+                    Just tc' -> return tc'
+
+                    -- FIXME: just for now
+                    Nothing  -> pprTrace "ccTyCon:" (ppr tc) $ return tc
+
+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 vectType [ty1,ty2])
+vectType ty@(ForAllTy _ _)
+  = do
+      mdicts   <- mapM paDictArgType tyvars
+      mono_ty' <- vectType mono_ty
+      return $ tyvars `mkForAllTys` ([dict | Just dict <- mdicts] `mkFunTys` mono_ty')
+  where
+    (tyvars, mono_ty) = splitForAllTys ty
+
+vectType ty = pprPanic "vectType:" (ppr ty)
+
diff --git a/compiler/vectorise/Vectorise.hs b/compiler/vectorise/Vectorise.hs
index 50e5923..4e84e13 100644
--- a/compiler/vectorise/Vectorise.hs
+++ b/compiler/vectorise/Vectorise.hs
@@ -5,6 +5,7 @@ where
 
 import VectMonad
 import VectUtils
+import VectType
 
 import DynFlags
 import HscTypes
@@ -18,7 +19,6 @@ import Rules                ( RuleBase )
 import DataCon
 import TyCon
 import Type
-import TypeRep
 import Var
 import VarEnv
 import VarSet
@@ -39,7 +39,6 @@ import BasicTypes           ( Boxity(..) )
 import Outputable
 import FastString
 import Control.Monad        ( liftM, liftM2, mapAndUnzipM, zipWithM_ )
-import Data.Maybe           ( maybeToList )
 
 vectorise :: HscEnv -> UniqSupply -> RuleBase -> ModGuts
           -> IO (SimplCount, ModGuts)
@@ -279,8 +278,8 @@ vectExpr lc (fvs, AnnLam bndr body)
       res_ty <- vectType (exprType $ deAnnotate body)
 
       -- FIXME: move the functions to the top level
-      mono_vfn <- applyToTypes (Var vfn_var) (map TyVarTy tyvars)
-      mono_lfn <- applyToTypes (Var lfn_var) (map TyVarTy tyvars)
+      mono_vfn <- applyToTypes (Var vfn_var) (mkTyVarTys tyvars)
+      mono_lfn <- applyToTypes (Var lfn_var) (mkTyVarTys tyvars)
 
       mk_clo <- builtin mkClosureVar
       mk_cloP <- builtin mkClosurePVar
@@ -425,33 +424,4 @@ vectTyAppExpr lc e tys = pprPanic "vectTyAppExpr" (ppr $ deAnnotate e)
 -- ----------------------------------------------------------------------------
 -- Types
 
-vectTyCon :: TyCon -> VM TyCon
-vectTyCon tc
-  | isFunTyCon tc        = builtin closureTyCon
-  | isBoxedTupleTyCon tc = return tc
-  | isUnLiftedTyCon tc   = return tc
-  | otherwise = do
-                  r <- lookupTyCon tc
-                  case r of
-                    Just tc' -> return tc'
-
-                    -- FIXME: just for now
-                    Nothing  -> pprTrace "ccTyCon:" (ppr tc) $ return tc
-
-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 vectType [ty1,ty2])
-vectType ty@(ForAllTy _ _)
-  = do
-      mdicts   <- mapM paDictArgType tyvars
-      mono_ty' <- vectType mono_ty
-      return $ tyvars `mkForAllTys` ([dict | Just dict <- mdicts] `mkFunTys` mono_ty')
-  where
-    (tyvars, mono_ty) = splitForAllTys ty
-
-vectType ty = pprPanic "vectType:" (ppr ty)
 
-- 
1.7.10.4