-import Data.List ( inits, tails, zipWith4, zipWith6 )
-
--- ----------------------------------------------------------------------------
--- Types
-
-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
-
-
-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])
-vectType ty@(ForAllTy _ _)
- = do
- mdicts <- mapM paDictArgType tyvars
- mono_ty' <- vectType mono_ty
- return $ abstractType tyvars [dict | Just dict <- mdicts] mono_ty'
- where
- (tyvars, mono_ty) = splitForAllTys ty
-
-vectType ty = cantVectorise "Can't vectorise type" (ppr ty)
-
-vectAndBoxType :: Type -> VM Type
-vectAndBoxType ty = vectType ty >>= boxType
-
-abstractType :: [TyVar] -> [Type] -> Type -> Type
-abstractType tyvars dicts = mkForAllTys tyvars . mkFunTys dicts
-
--- ----------------------------------------------------------------------------
--- 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