compiler/vectorise/Vectorise/Type/TyConDecl.hs

   1 module Vectorise.Type.TyConDecl
   2         (vectTyConDecls)
   3 where
   4 import Vectorise.Type.Type
   5 import Vectorise.Monad
   6 import BuildTyCl
   7 import Class
   8 import Type
   9 import TyCon
  10 import DataCon
  11 import BasicTypes
  12 import Var
  13 import Name
  14 import Outputable
  15 import Util
  16 import Control.Monad
  17
  18
  19 -- | Vectorise some (possibly recursively defined) type constructors.
  20 vectTyConDecls :: [TyCon] -> VM [TyCon]
  21 vectTyConDecls tcs = fixV $ \tcs' ->
  22   do
  23     mapM_ (uncurry defTyCon) (zipLazy tcs tcs')
  24     mapM vectTyConDecl tcs
  25
  26
  27 -- | Vectorise a single type construcrtor.
  28 vectTyConDecl :: TyCon -> VM TyCon
  29 vectTyConDecl tycon
  30     -- a type class constructor.
  31     -- TODO: check for no stupid theta, fds, assoc types.
  32     | isClassTyCon tycon
  33     , Just cls          <- tyConClass_maybe tycon
  34
  35     = do    -- make the name of the vectorised class tycon.
  36             name'       <- cloneName mkVectTyConOcc (tyConName tycon)
  37
  38             -- vectorise right of definition.
  39             rhs'        <- vectAlgTyConRhs tycon (algTyConRhs tycon)
  40
  41             -- vectorise method selectors.
  42             -- This also adds a mapping between the original and vectorised method selector
  43             -- to the state.
  44             methods'    <- mapM vectMethod
  45                         $  [(id, defMethSpecOfDefMeth meth)
  46                                 | (id, meth)    <- classOpItems cls]
  47
  48             -- keep the original recursiveness flag.
  49             let rec_flag = boolToRecFlag (isRecursiveTyCon tycon)
  50
  51             -- Calling buildclass here attaches new quantifiers and dictionaries to the method types.
  52             cls'     <- liftDs
  53                     $  buildClass
  54                              False               -- include unfoldings on dictionary selectors.
  55                              name'               -- new name  V_T:Class
  56                              (tyConTyVars tycon) -- keep original type vars
  57                              []                  -- no stupid theta
  58                              []                  -- no functional dependencies
  59                              []                  -- no associated types
  60                              methods'            -- method info
  61                              rec_flag            -- whether recursive
  62
  63             let tycon'  = mkClassTyCon name'
  64                              (tyConKind tycon)
  65                              (tyConTyVars tycon)
  66                              rhs'
  67                              cls'
  68                              rec_flag
  69
  70             return $ tycon'
  71
  72     -- a regular algebraic type constructor.
  73     -- TODO: check for stupid theta, generaics, GADTS etc
  74     | isAlgTyCon tycon
  75     = do    name'       <- cloneName mkVectTyConOcc (tyConName tycon)
  76             rhs'        <- vectAlgTyConRhs tycon (algTyConRhs tycon)
  77             let rec_flag =  boolToRecFlag (isRecursiveTyCon tycon)
  78
  79             liftDs $ buildAlgTyCon
  80                             name'               -- new name
  81                             (tyConTyVars tycon) -- keep original type vars.
  82                             []                  -- no stupid theta.
  83                             rhs'                -- new constructor defs.
  84                             rec_flag            -- FIXME: is this ok?
  85                             False               -- FIXME: no generics
  86                             False               -- not GADT syntax
  87                             NoParentTyCon
  88                             Nothing             -- not a family instance
  89
  90     -- some other crazy thing that we don't handle.
  91     | otherwise
  92     = cantVectorise "Can't vectorise type constructor: " (ppr tycon)
  93
  94
  95 -- | Vectorise a class method.
  96 vectMethod :: (Id, DefMethSpec) -> VM (Name, DefMethSpec, Type)
  97 vectMethod (id, defMeth)
  98  = do
  99         -- Vectorise the method type.
 100         typ'    <- vectType (varType id)
 101
 102         -- Create a name for the vectorised method.
 103         id'     <- cloneId mkVectOcc id typ'
 104         defGlobalVar id id'
 105
 106         -- When we call buildClass in vectTyConDecl, it adds foralls and dictionaries
 107         -- to the types of each method. However, the types we get back from vectType
 108         -- above already already have these, so we need to chop them off here otherwise
 109         -- we'll get two copies in the final version.
 110         let (_tyvars, tyBody) = splitForAllTys typ'
 111         let (_dict,   tyRest) = splitFunTy tyBody
 112
 113         return  (Var.varName id', defMeth, tyRest)
 114
 115
 116 -- | Vectorise the RHS of an algebraic type.
 117 vectAlgTyConRhs :: TyCon -> AlgTyConRhs -> VM AlgTyConRhs
 118 vectAlgTyConRhs _ (DataTyCon { data_cons = data_cons
 119                              , is_enum   = is_enum
 120                              })
 121   = do
 122       data_cons' <- mapM vectDataCon data_cons
 123       zipWithM_ defDataCon data_cons data_cons'
 124       return $ DataTyCon { data_cons = data_cons'
 125                          , is_enum   = is_enum
 126                          }
 127
 128 vectAlgTyConRhs tc _
 129         = cantVectorise "Can't vectorise type definition:" (ppr tc)
 130
 131
 132 -- | Vectorise a data constructor.
 133 --   Vectorises its argument and return types.
 134 vectDataCon :: DataCon -> VM DataCon
 135 vectDataCon dc
 136   | not . null $ dataConExTyVars dc
 137   = cantVectorise "Can't vectorise constructor (existentials):" (ppr dc)
 138
 139   | not . null $ dataConEqSpec   dc
 140   = cantVectorise "Can't vectorise constructor (eq spec):" (ppr dc)
 141
 142   | otherwise
 143   = do
 144       name'    <- cloneName mkVectDataConOcc name
 145       tycon'   <- vectTyCon tycon
 146       arg_tys  <- mapM vectType rep_arg_tys
 147
 148       liftDs $ buildDataCon
 149                 name'
 150                 False                          -- not infix
 151                 (map (const HsNoBang) arg_tys) -- strictness annots on args.
 152                 []                             -- no labelled fields
 153                 univ_tvs                       -- universally quantified vars
 154                 []                             -- no existential tvs for now
 155                 []                             -- no eq spec for now
 156                 []                             -- no context
 157                 arg_tys                        -- argument types
 158                 (mkFamilyTyConApp tycon' (mkTyVarTys univ_tvs)) -- return type
 159                 tycon'                         -- representation tycon
 160   where
 161     name        = dataConName dc
 162     univ_tvs    = dataConUnivTyVars dc
 163     rep_arg_tys = dataConRepArgTys dc
 164     tycon       = dataConTyCon dc