Commit df62b50d authored by rl@cse.unsw.edu.au's avatar rl@cse.unsw.edu.au
Browse files

Move type vectorisation code to a separate module

parent 13ae8118
......@@ -260,6 +260,7 @@ exposed-modules:
VarEnv
VarSet
VectMonad
VectType
VectUtils
Vectorise
WorkWrap
......
module VectType ( vectTyCon, vectType )
where
#include "HsVersions.h"
import VectMonad
import VectUtils
import TyCon
import Type
import TypeRep
import Outputable
import Control.Monad ( liftM2 )
vectTyCon :: TyCon -> VM TyCon
vectTyCon tc
| isFunTyCon tc = builtin closureTyCon
| isBoxedTupleTyCon tc = return tc
| isUnLiftedTyCon tc = return tc
| otherwise = do
r <- lookupTyCon tc
case r of
Just tc' -> return tc'
-- FIXME: just for now
Nothing -> pprTrace "ccTyCon:" (ppr tc) $ return tc
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 vectType [ty1,ty2])
vectType ty@(ForAllTy _ _)
= do
mdicts <- mapM paDictArgType tyvars
mono_ty' <- vectType mono_ty
return $ tyvars `mkForAllTys` ([dict | Just dict <- mdicts] `mkFunTys` mono_ty')
where
(tyvars, mono_ty) = splitForAllTys ty
vectType ty = pprPanic "vectType:" (ppr ty)
......@@ -5,6 +5,7 @@ where
import VectMonad
import VectUtils
import VectType
import DynFlags
import HscTypes
......@@ -18,7 +19,6 @@ import Rules ( RuleBase )
import DataCon
import TyCon
import Type
import TypeRep
import Var
import VarEnv
import VarSet
......@@ -39,7 +39,6 @@ import BasicTypes ( Boxity(..) )
import Outputable
import FastString
import Control.Monad ( liftM, liftM2, mapAndUnzipM, zipWithM_ )
import Data.Maybe ( maybeToList )
vectorise :: HscEnv -> UniqSupply -> RuleBase -> ModGuts
-> IO (SimplCount, ModGuts)
......@@ -279,8 +278,8 @@ vectExpr lc (fvs, AnnLam bndr body)
res_ty <- vectType (exprType $ deAnnotate body)
-- FIXME: move the functions to the top level
mono_vfn <- applyToTypes (Var vfn_var) (map TyVarTy tyvars)
mono_lfn <- applyToTypes (Var lfn_var) (map TyVarTy tyvars)
mono_vfn <- applyToTypes (Var vfn_var) (mkTyVarTys tyvars)
mono_lfn <- applyToTypes (Var lfn_var) (mkTyVarTys tyvars)
mk_clo <- builtin mkClosureVar
mk_cloP <- builtin mkClosurePVar
......@@ -425,33 +424,4 @@ vectTyAppExpr lc e tys = pprPanic "vectTyAppExpr" (ppr $ deAnnotate e)
-- ----------------------------------------------------------------------------
-- Types
vectTyCon :: TyCon -> VM TyCon
vectTyCon tc
| isFunTyCon tc = builtin closureTyCon
| isBoxedTupleTyCon tc = return tc
| isUnLiftedTyCon tc = return tc
| otherwise = do
r <- lookupTyCon tc
case r of
Just tc' -> return tc'
-- FIXME: just for now
Nothing -> pprTrace "ccTyCon:" (ppr tc) $ return tc
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 vectType [ty1,ty2])
vectType ty@(ForAllTy _ _)
= do
mdicts <- mapM paDictArgType tyvars
mono_ty' <- vectType mono_ty
return $ tyvars `mkForAllTys` ([dict | Just dict <- mdicts] `mkFunTys` mono_ty')
where
(tyvars, mono_ty) = splitForAllTys ty
vectType ty = pprPanic "vectType:" (ppr ty)
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment