-module VectType ( vectTyCon, vectType )
+module VectType ( vectTyCon, vectType, vectTypeEnv )
where
#include "HsVersions.h"
import VectMonad
import VectUtils
+import HscTypes ( TypeEnv, extendTypeEnvList, typeEnvTyCons )
import DataCon
import TyCon
import Type
import TypeRep
+import OccName
+import MkId
+import BasicTypes ( StrictnessMark(..), boolToRecFlag )
+import NameEnv
+import TysWiredIn
+import Unique
import UniqFM
import UniqSet
import Digraph ( SCC(..), stronglyConnComp )
import Outputable
-import Control.Monad ( liftM2 )
+import Control.Monad ( liftM2, zipWithM_ )
-- ----------------------------------------------------------------------------
-- Types
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 tcs = fixV $ \tcs' ->
+ do
+ mapM_ (uncurry defTyCon) (lazy_zip tcs tcs')
+ mapM vectTyConDecl tcs
+ where
+ lazy_zip [] _ = []
+ lazy_zip (x:xs) ~(y:ys) = (x,y) : lazy_zip xs ys
+
+vectTyConDecl :: TyCon -> VM TyCon
+vectTyConDecl tc
+ = do
+ name' <- cloneName mkVectTyConOcc name
+ rhs' <- vectAlgTyConRhs (algTyConRhs tc)
+
+ return $ mkAlgTyCon name'
+ kind
+ tyvars
+ [] -- no stupid theta
+ rhs'
+ [] -- no selector ids
+ NoParentTyCon -- FIXME
+ rec_flag -- FIXME: is this ok?
+ False -- FIXME: no generics
+ False -- not GADT syntax
+ where
+ name = tyConName tc
+ kind = tyConKind tc
+ tyvars = tyConTyVars tc
+ rec_flag = boolToRecFlag (isRecursiveTyCon tc)
+
+vectAlgTyConRhs :: AlgTyConRhs -> VM AlgTyConRhs
+vectAlgTyConRhs (DataTyCon { data_cons = data_cons
+ , is_enum = is_enum
+ })
+ = do
+ data_cons' <- mapM vectDataCon data_cons
+ zipWithM_ defDataCon data_cons data_cons'
+ return $ DataTyCon { data_cons = data_cons'
+ , is_enum = is_enum
+ }
+
+vectDataCon :: DataCon -> VM DataCon
+vectDataCon dc
+ | not . null $ dataConExTyVars dc = pprPanic "vectDataCon: existentials" (ppr dc)
+ | not . null $ dataConEqSpec dc = pprPanic "vectDataCon: eq spec" (ppr dc)
+ | otherwise
+ = do
+ name' <- cloneName mkVectDataConOcc name
+ tycon' <- vectTyCon tycon
+ arg_tys <- mapM vectType rep_arg_tys
+ wrk_name <- cloneName mkDataConWorkerOcc name'
+
+ let ids = mkDataConIds (panic "vectDataCon: wrapper id")
+ wrk_name
+ data_con
+ data_con = mkDataCon name'
+ False -- not infix
+ (map (const NotMarkedStrict) arg_tys)
+ [] -- no labelled fields
+ univ_tvs
+ [] -- no existential tvs for now
+ [] -- no eq spec for now
+ [] -- no theta
+ arg_tys
+ tycon'
+ [] -- no stupid theta
+ ids
+ return data_con
+ where
+ name = dataConName dc
+ univ_tvs = dataConUnivTyVars dc
+ rep_arg_tys = dataConRepArgTys dc
+ tycon = dataConTyCon dc
+
+{-
+mkPArrTyCon :: TyCon -> VM TyCon
+mkPArrTyCon tc = fixV $ \repr_tc ->
+ do
+-}
+
+mkPArrayDataCon :: TyCon -> TyCon -> VM DataCon
+mkPArrayDataCon orig_tc repr_tc
+ = do
+ name <- cloneName mkPArrayDataConOcc (tyConName orig_tc)
+ shape_ty <- mkPArrayType intTy -- FIXME: we want to unbox this!
+ repr_tys <- mapM mkPArrayType types
+ wrk_name <- cloneName mkDataConWorkerOcc name
+ wrp_name <- cloneName mkDataConWrapperOcc name
+
+ let ids = mkDataConIds wrp_name wrk_name data_con
+ data_con = mkDataCon name
+ False
+ (MarkedStrict : map (const NotMarkedStrict) repr_tys)
+ []
+ (tyConTyVars orig_tc)
+ []
+ []
+ []
+ repr_tys
+ repr_tc
+ []
+ ids
+
+ return data_con
+ where
+ types = [ty | dc <- tyConDataCons orig_tc
+ , ty <- dataConRepArgTys dc]
+
-- | 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:
tyConsOfType ty
| Just ty' <- coreView ty = tyConsOfType ty'
tyConsOfType (TyVarTy v) = emptyUniqSet
-tyConsOfType (TyConApp tc tys) = tyConsOfTypes tys `addOneToUniqSet` tc
+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
projects / ghc-hetmet.git / blobdiff