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

Vectorise type declarations

parent ae7dacf4
module VectType ( vectTyCon, vectType ) module VectType ( vectTyCon, vectType, vectTypeEnv )
where where
#include "HsVersions.h" #include "HsVersions.h"
...@@ -6,6 +6,7 @@ where ...@@ -6,6 +6,7 @@ where
import VectMonad import VectMonad
import VectUtils import VectUtils
import HscTypes ( TypeEnv, extendTypeEnvList, typeEnvTyCons )
import DataCon import DataCon
import TyCon import TyCon
import Type import Type
...@@ -13,7 +14,9 @@ import TypeRep ...@@ -13,7 +14,9 @@ import TypeRep
import OccName import OccName
import MkId import MkId
import BasicTypes ( StrictnessMark(..), boolToRecFlag ) import BasicTypes ( StrictnessMark(..), boolToRecFlag )
import NameEnv
import Unique
import UniqFM import UniqFM
import UniqSet import UniqSet
import Digraph ( SCC(..), stronglyConnComp ) import Digraph ( SCC(..), stronglyConnComp )
...@@ -60,6 +63,29 @@ vectType ty = pprPanic "vectType:" (ppr ty) ...@@ -60,6 +63,29 @@ vectType ty = pprPanic "vectType:" (ppr ty)
type TyConGroup = ([TyCon], UniqSet TyCon) type TyConGroup = ([TyCon], UniqSet TyCon)
vectTypeEnv :: TypeEnv -> VM TypeEnv
vectTypeEnv env
= do
cs <- readGEnv $ mk_map . global_tycons
let (conv_tcs, keep_tcs) = classifyTyCons cs groups
keep_dcs = concatMap tyConDataCons keep_tcs
zipWithM_ defTyCon keep_tcs keep_tcs
zipWithM_ defDataCon keep_dcs keep_dcs
new_tcs <- vectTyConDecls conv_tcs
return $ extendTypeEnvList env
(map ATyCon new_tcs ++ [ADataCon dc | tc <- new_tcs
, dc <- tyConDataCons tc])
where
tycons = typeEnvTyCons env
groups = tyConGroups tycons
mk_map env = listToUFM_Directly [(u, getUnique n /= u) | (u,n) <- nameEnvUniqueElts env]
keep_tc tc = let dcs = tyConDataCons tc
in
defTyCon tc tc >> zipWithM_ defDataCon dcs dcs
vectTyConDecls :: [TyCon] -> VM [TyCon] vectTyConDecls :: [TyCon] -> VM [TyCon]
vectTyConDecls tcs = fixV $ \tcs' -> vectTyConDecls tcs = fixV $ \tcs' ->
do do
......
...@@ -56,8 +56,10 @@ vectorise hsc_env _ _ guts ...@@ -56,8 +56,10 @@ vectorise hsc_env _ _ guts
vectModule :: ModGuts -> VM ModGuts vectModule :: ModGuts -> VM ModGuts
vectModule guts vectModule guts
= do = do
types' <- vectTypeEnv (mg_types guts)
binds' <- mapM vectTopBind (mg_binds guts) binds' <- mapM vectTopBind (mg_binds guts)
return $ guts { mg_binds = binds' } return $ guts { mg_types = types'
, mg_binds = binds' }
vectTopBind :: CoreBind -> VM CoreBind vectTopBind :: CoreBind -> VM CoreBind
vectTopBind b@(NonRec var expr) vectTopBind b@(NonRec var expr)
......
Supports Markdown
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