X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fvectorise%2FVectorise%2FType%2FTyConDecl.hs;fp=compiler%2Fvectorise%2FVectorise%2FType%2FTyConDecl.hs;h=34ce559e5176be438a260f909dd2c163a47f2f2b;hb=fb12748edd4e2ad72d2af0736494414955f65aae;hp=0000000000000000000000000000000000000000;hpb=099ead5c6163eb36d49d2883326128111b592825;p=ghc-hetmet.git

diff --git a/compiler/vectorise/Vectorise/Type/TyConDecl.hs b/compiler/vectorise/Vectorise/Type/TyConDecl.hs
new file mode 100644
index 0000000..34ce559
--- /dev/null
+++ b/compiler/vectorise/Vectorise/Type/TyConDecl.hs
@@ -0,0 +1,163 @@
+module Vectorise.Type.TyConDecl
+	(vectTyConDecls)
+where
+import Vectorise.Type.Type
+import Vectorise.Monad
+import BuildTyCl
+import Class
+import Type
+import TyCon
+import DataCon
+import BasicTypes
+import Var
+import Name
+import Outputable
+import Util
+import Control.Monad
+
+
+-- | Vectorise some (possibly recursively defined) type constructors.
+vectTyConDecls :: [TyCon] -> VM [TyCon]
+vectTyConDecls tcs = fixV $ \tcs' ->
+  do
+    mapM_ (uncurry defTyCon) (zipLazy tcs tcs')
+    mapM vectTyConDecl tcs
+
+
+-- | Vectorise a single type construcrtor.
+vectTyConDecl :: TyCon -> VM TyCon
+vectTyConDecl tycon
+    -- a type class constructor.
+    -- TODO: check for no stupid theta, fds, assoc types. 
+    | isClassTyCon tycon
+    , Just cls		<- tyConClass_maybe tycon
+
+    = do    -- make the name of the vectorised class tycon.
+	    name'	<- cloneName mkVectTyConOcc (tyConName tycon)
+
+            -- vectorise right of definition.
+            rhs'        <- vectAlgTyConRhs tycon (algTyConRhs tycon)
+
+            -- vectorise method selectors.
+            -- This also adds a mapping between the original and vectorised method selector
+            -- to the state.
+            methods'	<- mapM vectMethod
+			$  [(id, defMethSpecOfDefMeth meth) 
+				| (id, meth)	<- classOpItems cls]
+
+            -- keep the original recursiveness flag.
+            let rec_flag = boolToRecFlag (isRecursiveTyCon tycon)
+	
+	    -- Calling buildclass here attaches new quantifiers and dictionaries to the method types.
+            cls'     <- liftDs 
+             	    $  buildClass
+                             False               -- include unfoldings on dictionary selectors.
+                             name'               -- new name  V_T:Class
+                             (tyConTyVars tycon) -- keep original type vars
+                             []                  -- no stupid theta
+                             []                  -- no functional dependencies
+                             []                  -- no associated types
+                             methods'            -- method info
+                             rec_flag            -- whether recursive
+
+            let tycon'  = mkClassTyCon name'
+			     (tyConKind tycon)
+			     (tyConTyVars tycon)
+			     rhs'
+			     cls'
+			     rec_flag
+
+            return $ tycon'
+			
+    -- a regular algebraic type constructor.
+    -- TODO: check for stupid theta, generaics, GADTS etc
+    | isAlgTyCon tycon
+    = do    name'	<- cloneName mkVectTyConOcc (tyConName tycon)
+            rhs'	<- vectAlgTyConRhs tycon (algTyConRhs tycon)
+            let rec_flag =  boolToRecFlag (isRecursiveTyCon tycon)
+
+            liftDs $ buildAlgTyCon 
+                            name'               -- new name
+                            (tyConTyVars tycon) -- keep original type vars.
+                            []                  -- no stupid theta.
+                            rhs'                -- new constructor defs.
+                            rec_flag            -- FIXME: is this ok?
+                            False               -- FIXME: no generics
+                            False               -- not GADT syntax
+                            Nothing             -- not a family instance
+
+    -- some other crazy thing that we don't handle.
+    | otherwise
+    = cantVectorise "Can't vectorise type constructor: " (ppr tycon)
+
+
+-- | Vectorise a class method.
+vectMethod :: (Id, DefMethSpec) -> VM (Name, DefMethSpec, Type)
+vectMethod (id, defMeth)
+ = do	
+	-- Vectorise the method type.
+	typ'	<- vectType (varType id)
+
+	-- Create a name for the vectorised method.
+	id'	<- cloneId mkVectOcc id typ'
+	defGlobalVar id id'
+
+	-- When we call buildClass in vectTyConDecl, it adds foralls and dictionaries
+	-- to the types of each method. However, the types we get back from vectType
+	-- above already already have these, so we need to chop them off here otherwise
+	-- we'll get two copies in the final version.
+	let (_tyvars, tyBody) = splitForAllTys typ'
+	let (_dict,   tyRest) = splitFunTy tyBody
+
+	return	(Var.varName id', defMeth, tyRest)
+
+
+-- | Vectorise the RHS of an algebraic type.
+vectAlgTyConRhs :: TyCon -> 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
+                         }
+
+vectAlgTyConRhs tc _ 
+	= cantVectorise "Can't vectorise type definition:" (ppr tc)
+
+
+-- | Vectorise a data constructor.
+--   Vectorises its argument and return types.
+vectDataCon :: DataCon -> VM DataCon
+vectDataCon dc
+  | not . null $ dataConExTyVars dc
+  = cantVectorise "Can't vectorise constructor (existentials):" (ppr dc)
+
+  | not . null $ dataConEqSpec   dc
+  = cantVectorise "Can't vectorise constructor (eq spec):" (ppr dc)
+
+  | otherwise
+  = do
+      name'    <- cloneName mkVectDataConOcc name
+      tycon'   <- vectTyCon tycon
+      arg_tys  <- mapM vectType rep_arg_tys
+
+      liftDs $ buildDataCon 
+		name'
+                False                          -- not infix
+                (map (const HsNoBang) arg_tys) -- strictness annots on args.
+                []                             -- no labelled fields
+                univ_tvs                       -- universally quantified vars
+                []                             -- no existential tvs for now
+                []                             -- no eq spec for now
+                []                             -- no context
+                arg_tys                        -- argument types
+		(mkFamilyTyConApp tycon' (mkTyVarTys univ_tvs)) -- return type
+                tycon'                         -- representation tycon
+  where
+    name        = dataConName dc
+    univ_tvs    = dataConUnivTyVars dc
+    rep_arg_tys = dataConRepArgTys dc
+    tycon       = dataConTyCon dc