Break out conversion functions to own module

diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index 06d7e28..f4622b1 100644 (file)
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -457,6 +457,7 @@ Library
         VectType
         VectUtils
         Vectorise.Var
         VectType
         VectUtils
         Vectorise.Var

+        Vectorise.Convert

         Vectorise.Env
         Vectorise.Vect
         Vectorise.Exp
         Vectorise.Env
         Vectorise.Vect
         Vectorise.Exp

diff --git a/compiler/vectorise/VectType.hs b/compiler/vectorise/VectType.hs
index 046acb9..96d48b5 100644 (file)
--- a/compiler/vectorise/VectType.hs
+++ b/compiler/vectorise/VectType.hs
@@ -8,6 +8,7 @@ where
 
 import VectUtils
 import Vectorise.Env
 
 import VectUtils
 import Vectorise.Env

+import Vectorise.Convert

 import Vectorise.Vect
 import Vectorise.Monad
 import Vectorise.Builtins
 import Vectorise.Vect
 import Vectorise.Monad
 import Vectorise.Builtins

@@ -27,7 +28,6 @@ import BuildTyCl
 import DataCon
 import TyCon
 import Type
 import DataCon
 import TyCon
 import Type

-import TypeRep

 import Coercion
 import FamInstEnv        ( FamInst, mkLocalFamInst )
 import OccName
 import Coercion
 import FamInstEnv        ( FamInst, mkLocalFamInst )
 import OccName

@@ -52,13 +52,14 @@ debug               = False
 dtrace s x     = if debug then pprTrace "VectType" s x else x
 
 
 dtrace s x     = if debug then pprTrace "VectType" s x else x
 
 

--- ----------------------------------------------------------------------------
--- Type definitions
-
-

 -- | Vectorise a type environment.
 --   The type environment contains all the type things defined in a module.
 -- | Vectorise a type environment.
 --   The type environment contains all the type things defined in a module.

-vectTypeEnv :: TypeEnv -> VM (TypeEnv, [FamInst], [(Var, CoreExpr)])
+vectTypeEnv 
+       :: TypeEnv
+       -> VM ( TypeEnv                 -- Vectorised type environment.
+             , [FamInst]               -- New type family instances.
+             , [(Var, CoreExpr)])      -- New top level bindings.
+       

 vectTypeEnv env
  = dtrace (ppr env)
  $ do
 vectTypeEnv env
  = dtrace (ppr env)
  $ do

@@ -748,76 +749,3 @@ paMethods = [("dictPRepr",    buildPRDict),
              ("fromArrPRepr", buildFromArrPRepr)]
 
 
              ("fromArrPRepr", buildFromArrPRepr)]
 
 

--- ----------------------------------------------------------------------------
--- Conversions
-
--- | Build an expression that calls the vectorised version of some 
---   function from a `Closure`.
---
---   For example
---   @   
---      \(x :: Double) -> 
---      \(y :: Double) -> 
---      ($v_foo $: x) $: y
---   @
---
---   We use the type of the original binding to work out how many
---   outer lambdas to add.
---
-fromVect 
-       :: Type         -- ^ The type of the original binding.
-       -> CoreExpr     -- ^ Expression giving the closure to use, eg @$v_foo@.
-       -> VM CoreExpr
-       
--- Convert the type to the core view if it isn't already.
-fromVect ty expr 
-       | Just ty' <- coreView ty 
-       = fromVect ty' expr
-
--- For each function constructor in the original type we add an outer 
--- lambda to bind the parameter variable, and an inner application of it.
-fromVect (FunTy arg_ty res_ty) expr
-  = do
-      arg     <- newLocalVar (fsLit "x") arg_ty
-      varg    <- toVect arg_ty (Var arg)
-      varg_ty <- vectType arg_ty
-      vres_ty <- vectType res_ty
-      apply   <- builtin applyVar
-      body    <- fromVect res_ty
-               $ Var apply `mkTyApps` [varg_ty, vres_ty] `mkApps` [expr, varg]
-      return $ Lam arg body
-
--- If the type isn't a function then it's time to call on the closure.
-fromVect ty expr
-  = identityConv ty >> return expr
-
-
--- TODO: What is this really doing?
-toVect :: Type -> CoreExpr -> VM CoreExpr
-toVect ty expr = identityConv ty >> return expr
-
-
--- | Check that we have the vectorised versions of all the
---   type constructors in this type.
-identityConv :: Type -> VM ()
-identityConv ty 
-  | Just ty' <- coreView ty 
-  = identityConv ty'
-
-identityConv (TyConApp tycon tys)
- = do mapM_ identityConv tys
-      identityConvTyCon tycon
-
-identityConv _ = noV
-
-
--- | Check that we have the vectorised version of this type constructor.
-identityConvTyCon :: TyCon -> VM ()
-identityConvTyCon tc
-  | isBoxedTupleTyCon tc = return ()
-  | isUnLiftedTyCon tc   = return ()
-  | otherwise 
-  = do tc' <- maybeV (lookupTyCon tc)
-       if tc == tc' then return () else noV
-
-

diff --git a/compiler/vectorise/Vectorise/Convert.hs b/compiler/vectorise/Vectorise/Convert.hs
new file mode 100644 (file)
index 0000000..6e0c5a1
--- /dev/null
+++ b/compiler/vectorise/Vectorise/Convert.hs
@@ -0,0 +1,83 @@
+
+module Vectorise.Convert
+       (fromVect)
+where
+import Vectorise.Monad
+import Vectorise.Builtins
+import Vectorise.Type.Type
+
+import CoreSyn
+import TyCon
+import Type
+import TypeRep
+import FastString
+
+
+-- | Build an expression that calls the vectorised version of some 
+--   function from a `Closure`.
+--
+--   For example
+--   @   
+--      \(x :: Double) -> 
+--      \(y :: Double) -> 
+--      ($v_foo $: x) $: y
+--   @
+--
+--   We use the type of the original binding to work out how many
+--   outer lambdas to add.
+--
+fromVect 
+       :: Type         -- ^ The type of the original binding.
+       -> CoreExpr     -- ^ Expression giving the closure to use, eg @$v_foo@.
+       -> VM CoreExpr
+       
+-- Convert the type to the core view if it isn't already.
+fromVect ty expr 
+       | Just ty' <- coreView ty 
+       = fromVect ty' expr
+
+-- For each function constructor in the original type we add an outer 
+-- lambda to bind the parameter variable, and an inner application of it.
+fromVect (FunTy arg_ty res_ty) expr
+  = do
+      arg     <- newLocalVar (fsLit "x") arg_ty
+      varg    <- toVect arg_ty (Var arg)
+      varg_ty <- vectType arg_ty
+      vres_ty <- vectType res_ty
+      apply   <- builtin applyVar
+      body    <- fromVect res_ty
+               $ Var apply `mkTyApps` [varg_ty, vres_ty] `mkApps` [expr, varg]
+      return $ Lam arg body
+
+-- If the type isn't a function then it's time to call on the closure.
+fromVect ty expr
+  = identityConv ty >> return expr
+
+
+-- TODO: What is this really doing?
+toVect :: Type -> CoreExpr -> VM CoreExpr
+toVect ty expr = identityConv ty >> return expr
+
+
+-- | Check that we have the vectorised versions of all the
+--   type constructors in this type.
+identityConv :: Type -> VM ()
+identityConv ty 
+  | Just ty' <- coreView ty 
+  = identityConv ty'
+
+identityConv (TyConApp tycon tys)
+ = do mapM_ identityConv tys
+      identityConvTyCon tycon
+
+identityConv _ = noV
+
+
+-- | Check that we have the vectorised version of this type constructor.
+identityConvTyCon :: TyCon -> VM ()
+identityConvTyCon tc
+  | isBoxedTupleTyCon tc = return ()
+  | isUnLiftedTyCon tc   = return ()
+  | otherwise 
+  = do tc' <- maybeV (lookupTyCon tc)
+       if tc == tc' then return () else noV