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               -- not GADT syntax
  86                             NoParentTyCon
  87                             Nothing             -- not a family instance
  88
  89     -- some other crazy thing that we don't handle.
  90     | otherwise
  91     = cantVectorise "Can't vectorise type constructor: " (ppr tycon)
  92
  93
  94 -- | Vectorise a class method.
  95 vectMethod :: (Id, DefMethSpec) -> VM (Name, DefMethSpec, Type)
  96 vectMethod (id, defMeth)
  97  = do
  98         -- Vectorise the method type.
  99         typ'    <- vectType (varType id)
 100
 101         -- Create a name for the vectorised method.
 102         id'     <- cloneId mkVectOcc id typ'
 103         defGlobalVar id id'
 104
 105         -- When we call buildClass in vectTyConDecl, it adds foralls and dictionaries
 106         -- to the types of each method. However, the types we get back from vectType
 107         -- above already already have these, so we need to chop them off here otherwise
 108         -- we'll get two copies in the final version.
 109         let (_tyvars, tyBody) = splitForAllTys typ'
 110         let (_dict,   tyRest) = splitFunTy tyBody
 111
 112         return  (Var.varName id', defMeth, tyRest)
 113
 114
 115 -- | Vectorise the RHS of an algebraic type.
 116 vectAlgTyConRhs :: TyCon -> AlgTyConRhs -> VM AlgTyConRhs
 117 vectAlgTyConRhs _ (DataTyCon { data_cons = data_cons
 118                              , is_enum   = is_enum
 119                              })
 120   = do
 121       data_cons' <- mapM vectDataCon data_cons
 122       zipWithM_ defDataCon data_cons data_cons'
 123       return $ DataTyCon { data_cons = data_cons'
 124                          , is_enum   = is_enum
 125                          }
 126
 127 vectAlgTyConRhs tc _
 128         = cantVectorise "Can't vectorise type definition:" (ppr tc)
 129
 130
 131 -- | Vectorise a data constructor.
 132 --   Vectorises its argument and return types.
 133 vectDataCon :: DataCon -> VM DataCon
 134 vectDataCon dc
 135   | not . null $ dataConExTyVars dc
 136   = cantVectorise "Can't vectorise constructor (existentials):" (ppr dc)
 137
 138   | not . null $ dataConEqSpec   dc
 139   = cantVectorise "Can't vectorise constructor (eq spec):" (ppr dc)
 140
 141   | otherwise
 142   = do
 143       name'    <- cloneName mkVectDataConOcc name
 144       tycon'   <- vectTyCon tycon
 145       arg_tys  <- mapM vectType rep_arg_tys
 146
 147       liftDs $ buildDataCon
 148                 name'
 149                 False                          -- not infix
 150                 (map (const HsNoBang) arg_tys) -- strictness annots on args.
 151                 []                             -- no labelled fields
 152                 univ_tvs                       -- universally quantified vars
 153                 []                             -- no existential tvs for now
 154                 []                             -- no eq spec for now
 155                 []                             -- no context
 156                 arg_tys                        -- argument types
 157                 (mkFamilyTyConApp tycon' (mkTyVarTys univ_tvs)) -- return type
 158                 tycon'                         -- representation tycon
 159   where
 160     name        = dataConName dc
 161     univ_tvs    = dataConUnivTyVars dc
 162     rep_arg_tys = dataConRepArgTys dc
 163     tycon       = dataConTyCon dc