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
import DataCon
import TyCon
import Type
-import TypeRep
import Coercion
import FamInstEnv ( FamInst, mkLocalFamInst )
import OccName
import Unique
import UniqFM
-import UniqSet
import Util
-import Digraph ( SCC(..), stronglyConnCompFromEdgedVertices )
import Outputable
import FastString
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
("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
-
projects / ghc-hetmet.git / blobdiff