X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fvectorise%2FVectType.hs;h=96d48b542fbe59c2d17b411a853ce3283af8f262;hb=b8dbedceefebb3cf0bf05534033391a0211b0e63;hp=b8b851f18e603f697a2d38d6df142377c23e25b9;hpb=fb12748edd4e2ad72d2af0736494414955f65aae;p=ghc-hetmet.git

diff --git a/compiler/vectorise/VectType.hs b/compiler/vectorise/VectType.hs
index b8b851f..96d48b5 100644
--- a/compiler/vectorise/VectType.hs
+++ b/compiler/vectorise/VectType.hs
@@ -8,11 +8,15 @@ where
 
 import VectUtils
 import Vectorise.Env
+import Vectorise.Convert
 import Vectorise.Vect
 import Vectorise.Monad
 import Vectorise.Builtins
 import Vectorise.Type.Type
 import Vectorise.Type.TyConDecl
+import Vectorise.Type.Classify
+import Vectorise.Utils.Closure
+import Vectorise.Utils.Hoisting
 
 import HscTypes          ( TypeEnv, extendTypeEnvList, typeEnvTyCons )
 import BasicTypes
@@ -24,7 +28,6 @@ import BuildTyCl
 import DataCon
 import TyCon
 import Type
-import TypeRep
 import Coercion
 import FamInstEnv        ( FamInst, mkLocalFamInst )
 import OccName
@@ -36,9 +39,7 @@ import NameEnv
 
 import Unique
 import UniqFM
-import UniqSet
 import Util
-import Digraph           ( SCC(..), stronglyConnCompFromEdgedVertices )
 
 import Outputable
 import FastString
@@ -50,18 +51,15 @@ import Data.List
 debug		= False
 dtrace s x	= if debug then pprTrace "VectType" s x else x
 
--- ----------------------------------------------------------------------------
--- Types
-
-
--- ----------------------------------------------------------------------------
--- Type definitions
-
-type TyConGroup = ([TyCon], UniqSet TyCon)
 
 -- | 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
@@ -751,132 +749,3 @@ paMethods = [("dictPRepr",    buildPRDict),
              ("fromArrPRepr", buildFromArrPRepr)]
 
 
--- | Split the given tycons into two sets depending on whether they have to be
---   converted (first list) or not (second list). The first argument contains
---   information about the conversion status of external tycons:
---
---   * tycons which have converted versions are mapped to True
---   * tycons which are not changed by vectorisation are mapped to False
---   * tycons which can't be converted are not elements of the map
---
-classifyTyCons :: UniqFM Bool -> [TyConGroup] -> ([TyCon], [TyCon])
-classifyTyCons = classify [] []
-  where
-    classify conv keep _  [] = (conv, keep)
-    classify conv keep cs ((tcs, ds) : rs)
-      | can_convert && must_convert
-        = classify (tcs ++ conv) keep (cs `addListToUFM` [(tc,True) | tc <- tcs]) rs
-      | can_convert
-        = classify conv (tcs ++ keep) (cs `addListToUFM` [(tc,False) | tc <- tcs]) rs
-      | otherwise
-        = classify conv keep cs rs
-      where
-        refs = ds `delListFromUniqSet` tcs
-
-        can_convert  = isNullUFM (refs `minusUFM` cs) && all convertable tcs
-        must_convert = foldUFM (||) False (intersectUFM_C const cs refs)
-
-        convertable tc = isDataTyCon tc && all isVanillaDataCon (tyConDataCons tc)
-
--- | Compute mutually recursive groups of tycons in topological order
---
-tyConGroups :: [TyCon] -> [TyConGroup]
-tyConGroups tcs = map mk_grp (stronglyConnCompFromEdgedVertices edges)
-  where
-    edges = [((tc, ds), tc, uniqSetToList ds) | tc <- tcs
-                                , let ds = tyConsOfTyCon tc]
-
-    mk_grp (AcyclicSCC (tc, ds)) = ([tc], ds)
-    mk_grp (CyclicSCC els)       = (tcs, unionManyUniqSets dss)
-      where
-        (tcs, dss) = unzip els
-
-tyConsOfTyCon :: TyCon -> UniqSet TyCon
-tyConsOfTyCon
-  = tyConsOfTypes . concatMap dataConRepArgTys . tyConDataCons
-
-tyConsOfType :: Type -> UniqSet TyCon
-tyConsOfType ty
-  | Just ty' <- coreView ty    = tyConsOfType ty'
-tyConsOfType (TyVarTy _)       = emptyUniqSet
-tyConsOfType (TyConApp tc tys) = extend (tyConsOfTypes tys)
-  where
-    extend | isUnLiftedTyCon tc
-           || isTupleTyCon   tc = id
-
-           | otherwise          = (`addOneToUniqSet` tc)
-
-tyConsOfType (AppTy a b)       = tyConsOfType a `unionUniqSets` tyConsOfType b
-tyConsOfType (FunTy a b)       = (tyConsOfType a `unionUniqSets` tyConsOfType b)
-                                 `addOneToUniqSet` funTyCon
-tyConsOfType (ForAllTy _ ty)   = tyConsOfType ty
-tyConsOfType other             = pprPanic "ClosureConv.tyConsOfType" $ ppr other
-
-tyConsOfTypes :: [Type] -> UniqSet TyCon
-tyConsOfTypes = unionManyUniqSets . map tyConsOfType
-
-
--- ----------------------------------------------------------------------------
--- 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
-
-
-toVect :: Type -> CoreExpr -> VM CoreExpr
-toVect ty expr = identityConv ty >> return expr
-
-
-identityConv :: Type -> VM ()
-identityConv ty | Just ty' <- coreView ty = identityConv ty'
-identityConv (TyConApp tycon tys)
-  = do
-      mapM_ identityConv tys
-      identityConvTyCon tycon
-identityConv _ = noV
-
-identityConvTyCon :: TyCon -> VM ()
-identityConvTyCon tc
-  | isBoxedTupleTyCon tc = return ()
-  | isUnLiftedTyCon tc   = return ()
-  | otherwise            = do
-                             tc' <- maybeV (lookupTyCon tc)
-                             if tc == tc' then return () else noV
-