compiler/vectorise/VectType.hs

   1 module VectType ( vectTyCon, vectType )
   2 where
   3
   4 #include "HsVersions.h"
   5
   6 import VectMonad
   7 import VectUtils
   8
   9 import DataCon
  10 import TyCon
  11 import Type
  12 import TypeRep
  13 import OccName
  14 import MkId
  15 import BasicTypes        ( StrictnessMark(..), boolToRecFlag )
  16
  17 import UniqFM
  18 import UniqSet
  19 import Digraph           ( SCC(..), stronglyConnComp )
  20
  21 import Outputable
  22
  23 import Control.Monad  ( liftM2, zipWithM_ )
  24
  25 -- ----------------------------------------------------------------------------
  26 -- Types
  27
  28 vectTyCon :: TyCon -> VM TyCon
  29 vectTyCon tc
  30   | isFunTyCon tc        = builtin closureTyCon
  31   | isBoxedTupleTyCon tc = return tc
  32   | isUnLiftedTyCon tc   = return tc
  33   | otherwise = do
  34                   r <- lookupTyCon tc
  35                   case r of
  36                     Just tc' -> return tc'
  37
  38                     -- FIXME: just for now
  39                     Nothing  -> pprTrace "ccTyCon:" (ppr tc) $ return tc
  40
  41 vectType :: Type -> VM Type
  42 vectType ty | Just ty' <- coreView ty = vectType ty'
  43 vectType (TyVarTy tv) = return $ TyVarTy tv
  44 vectType (AppTy ty1 ty2) = liftM2 AppTy (vectType ty1) (vectType ty2)
  45 vectType (TyConApp tc tys) = liftM2 TyConApp (vectTyCon tc) (mapM vectType tys)
  46 vectType (FunTy ty1 ty2)   = liftM2 TyConApp (builtin closureTyCon)
  47                                              (mapM vectType [ty1,ty2])
  48 vectType ty@(ForAllTy _ _)
  49   = do
  50       mdicts   <- mapM paDictArgType tyvars
  51       mono_ty' <- vectType mono_ty
  52       return $ tyvars `mkForAllTys` ([dict | Just dict <- mdicts] `mkFunTys` mono_ty')
  53   where
  54     (tyvars, mono_ty) = splitForAllTys ty
  55
  56 vectType ty = pprPanic "vectType:" (ppr ty)
  57
  58 -- ----------------------------------------------------------------------------
  59 -- Type definitions
  60
  61 type TyConGroup = ([TyCon], UniqSet TyCon)
  62
  63 vectTyConDecls :: [TyCon] -> VM [TyCon]
  64 vectTyConDecls tcs = fixV $ \tcs' ->
  65   do
  66     mapM_ (uncurry defTyCon) (lazy_zip tcs tcs')
  67     mapM vectTyConDecl tcs
  68   where
  69     lazy_zip [] _ = []
  70     lazy_zip (x:xs) ~(y:ys) = (x,y) : lazy_zip xs ys
  71
  72 vectTyConDecl :: TyCon -> VM TyCon
  73 vectTyConDecl tc
  74   = do
  75       name' <- cloneName mkVectTyConOcc name
  76       rhs'  <- vectAlgTyConRhs (algTyConRhs tc)
  77
  78       return $ mkAlgTyCon name'
  79                           kind
  80                           tyvars
  81                           []              -- no stupid theta
  82                           rhs'
  83                           []              -- no selector ids
  84                           NoParentTyCon   -- FIXME
  85                           rec_flag        -- FIXME: is this ok?
  86                           False           -- FIXME: no generics
  87                           False           -- not GADT syntax
  88   where
  89     name   = tyConName tc
  90     kind   = tyConKind tc
  91     tyvars = tyConTyVars tc
  92     rec_flag = boolToRecFlag (isRecursiveTyCon tc)
  93
  94 vectAlgTyConRhs :: AlgTyConRhs -> VM AlgTyConRhs
  95 vectAlgTyConRhs (DataTyCon { data_cons = data_cons
  96                            , is_enum   = is_enum
  97                            })
  98   = do
  99       data_cons' <- mapM vectDataCon data_cons
 100       zipWithM_ defDataCon data_cons data_cons'
 101       return $ DataTyCon { data_cons = data_cons'
 102                          , is_enum   = is_enum
 103                          }
 104
 105 vectDataCon :: DataCon -> VM DataCon
 106 vectDataCon dc
 107   | not . null $ dataConExTyVars dc = pprPanic "vectDataCon: existentials" (ppr dc)
 108   | not . null $ dataConEqSpec   dc = pprPanic "vectDataCon: eq spec" (ppr dc)
 109   | otherwise
 110   = do
 111       name'    <- cloneName mkVectDataConOcc name
 112       tycon'   <- vectTyCon tycon
 113       arg_tys  <- mapM vectType rep_arg_tys
 114       wrk_name <- cloneName mkDataConWorkerOcc name'
 115
 116       let ids      = mkDataConIds (panic "vectDataCon: wrapped id")
 117                                   wrk_name
 118                                   data_con
 119           data_con = mkDataCon name'
 120                                False           -- not infix
 121                                (map (const NotMarkedStrict) arg_tys)
 122                                []              -- no labelled fields
 123                                univ_tvs
 124                                []              -- no existential tvs for now
 125                                []              -- no eq spec for now
 126                                []              -- no theta
 127                                arg_tys
 128                                tycon'
 129                                []              -- no stupid theta
 130                                ids
 131       return data_con
 132   where
 133     name        = dataConName dc
 134     univ_tvs    = dataConUnivTyVars dc
 135     rep_arg_tys = dataConOrigArgTys dc
 136     tycon       = dataConTyCon dc
 137
 138 -- | Split the given tycons into two sets depending on whether they have to be
 139 -- converted (first list) or not (second list). The first argument contains
 140 -- information about the conversion status of external tycons:
 141 --
 142 --   * tycons which have converted versions are mapped to True
 143 --   * tycons which are not changed by vectorisation are mapped to False
 144 --   * tycons which can't be converted are not elements of the map
 145 --
 146 classifyTyCons :: UniqFM Bool -> [TyConGroup] -> ([TyCon], [TyCon])
 147 classifyTyCons = classify [] []
 148   where
 149     classify conv keep cs [] = (conv, keep)
 150     classify conv keep cs ((tcs, ds) : rs)
 151       | can_convert && must_convert
 152         = classify (tcs ++ conv) keep (cs `addListToUFM` [(tc,True) | tc <- tcs]) rs
 153       | can_convert
 154         = classify conv (tcs ++ keep) (cs `addListToUFM` [(tc,False) | tc <- tcs]) rs
 155       | otherwise
 156         = classify conv keep cs rs
 157       where
 158         refs = ds `delListFromUniqSet` tcs
 159
 160         can_convert  = isNullUFM (refs `minusUFM` cs) && all convertable tcs
 161         must_convert = foldUFM (||) False (intersectUFM_C const cs refs)
 162
 163         convertable tc = isDataTyCon tc && all isVanillaDataCon (tyConDataCons tc)
 164
 165 -- | Compute mutually recursive groups of tycons in topological order
 166 --
 167 tyConGroups :: [TyCon] -> [TyConGroup]
 168 tyConGroups tcs = map mk_grp (stronglyConnComp edges)
 169   where
 170     edges = [((tc, ds), tc, uniqSetToList ds) | tc <- tcs
 171                                 , let ds = tyConsOfTyCon tc]
 172
 173     mk_grp (AcyclicSCC (tc, ds)) = ([tc], ds)
 174     mk_grp (CyclicSCC els)       = (tcs, unionManyUniqSets dss)
 175       where
 176         (tcs, dss) = unzip els
 177
 178 tyConsOfTyCon :: TyCon -> UniqSet TyCon
 179 tyConsOfTyCon
 180   = tyConsOfTypes . concatMap dataConRepArgTys . tyConDataCons
 181
 182 tyConsOfType :: Type -> UniqSet TyCon
 183 tyConsOfType ty
 184   | Just ty' <- coreView ty    = tyConsOfType ty'
 185 tyConsOfType (TyVarTy v)       = emptyUniqSet
 186 tyConsOfType (TyConApp tc tys) = tyConsOfTypes tys `addOneToUniqSet` tc
 187 tyConsOfType (AppTy a b)       = tyConsOfType a `unionUniqSets` tyConsOfType b
 188 tyConsOfType (FunTy a b)       = (tyConsOfType a `unionUniqSets` tyConsOfType b)
 189                                  `addOneToUniqSet` funTyCon
 190 tyConsOfType (ForAllTy _ ty)   = tyConsOfType ty
 191 tyConsOfType other             = pprPanic "ClosureConv.tyConsOfType" $ ppr other
 192
 193 tyConsOfTypes :: [Type] -> UniqSet TyCon
 194 tyConsOfTypes = unionManyUniqSets . map tyConsOfType
 195