import Vectorise.Vect
import Vectorise.Monad
import Vectorise.Builtins
+import Vectorise.Type.Type
import HscTypes ( TypeEnv, extendTypeEnvList, typeEnvTyCons )
import BasicTypes
import OccName
import Id
import MkId
-import Var ( Var, TyVar, varType, varName )
+import Var
import Name ( Name, getOccName )
import NameEnv
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
-- ----------------------------------------------------------------------------
-- 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