From: Matthijs Kooijman Date: Fri, 3 Jul 2009 11:27:57 +0000 (+0200) Subject: Merge git://github.com/darchon/clash into cλash X-Git-Url: https://git.stderr.nl/gitweb?a=commitdiff_plain;h=c8034ff49822eb6e0e0696f288e20e49a1b9af6e;hp=-c;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git Merge git://github.com/darchon/clash into cλash * git://github.com/darchon/clash: Keys for typemap can now deal with vector lengths based on type operators Conflicts: Generate.hs VHDLTools.hs --- c8034ff49822eb6e0e0696f288e20e49a1b9af6e diff --combined Generate.hs index 6b19bb5,dfd9fad..b3045de --- a/Generate.hs +++ b/Generate.hs @@@ -6,7 -6,6 +6,7 @@@ import qualified Data.Map as Ma import qualified Maybe import qualified Data.Either as Either import Data.Accessor +import Data.Accessor.MonadState as MonadState import Debug.Trace -- ForSyDe @@@ -72,16 -71,16 +72,16 @@@ genOperator1' op _ f [arg] = return $ o -- | Generate a function call from the destination binder, function name and a -- list of expressions (its arguments) - genFCall :: BuiltinBuilder - genFCall = genExprArgs $ genExprRes genFCall' - genFCall' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> VHDLSession AST.Expr - genFCall' (Left res) f args = do + genFCall :: Bool -> BuiltinBuilder + genFCall switch = genExprArgs $ genExprRes (genFCall' switch) + genFCall' :: Bool -> Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> VHDLSession AST.Expr + genFCall' switch (Left res) f args = do let fname = varToString f - let el_ty = (tfvec_elem . Var.varType) res + let el_ty = if switch then (Var.varType res) else ((tfvec_elem . Var.varType) res) - id <- vectorFunId el_ty fname + id <- MonadState.lift vsType $ vectorFunId el_ty fname return $ AST.PrimFCall $ AST.FCall (AST.NSimple id) $ map (\exp -> Nothing AST.:=>: AST.ADExpr exp) args - genFCall' (Right name) _ _ = error $ "\nGenerate.genFCall': Cannot generate builtin function call assigned to a VHDLName: " ++ show name + genFCall' _ (Right name) _ _ = error $ "\nGenerate.genFCall': Cannot generate builtin function call assigned to a VHDLName: " ++ show name -- | Generate a generate statement for the builtin function "map" genMap :: BuiltinBuilder @@@ -156,7 -155,7 +156,7 @@@ genFold' left (Left res) f [folded_f, s -- temporary vector let tmp_ty = Type.mkAppTy nvec (Var.varType start) let error_msg = "\nGenerate.genFold': Can not construct temp vector for element type: " ++ pprString tmp_ty - tmp_vhdl_ty <- vhdl_ty error_msg tmp_ty + tmp_vhdl_ty <- MonadState.lift vsType $ vhdl_ty error_msg tmp_ty -- Setup the generate scheme let gen_label = mkVHDLExtId ("foldlVector" ++ (varToString vec)) let block_label = mkVHDLExtId ("foldlVector" ++ (varToString start)) @@@ -246,7 -245,7 +246,7 @@@ genZip' (Left res) f args@[arg1, arg2] argexpr1 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg1) n_expr argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg2) n_expr in do - labels <- getFieldLabels (tfvec_elem (Var.varType res)) + labels <- MonadState.lift vsType $ getFieldLabels (tfvec_elem (Var.varType res)) let resnameA = mkSelectedName resname' (labels!!0) let resnameB = mkSelectedName resname' (labels!!1) let resA_assign = mkUncondAssign (Right resnameA) argexpr1 @@@ -271,8 -270,8 +271,8 @@@ genUnzip' (Left res) f args@[arg] resname' = varToVHDLName res argexpr' = mkIndexedName (varToVHDLName arg) n_expr in do - reslabels <- getFieldLabels (Var.varType res) - arglabels <- getFieldLabels (tfvec_elem (Var.varType arg)) + reslabels <- MonadState.lift vsType $ getFieldLabels (Var.varType res) + arglabels <- MonadState.lift vsType $ getFieldLabels (tfvec_elem (Var.varType arg)) let resnameA = mkIndexedName (mkSelectedName resname' (reslabels!!0)) n_expr let resnameB = mkIndexedName (mkSelectedName resname' (reslabels!!1)) n_expr let argexprA = vhdlNameToVHDLExpr $ mkSelectedName argexpr' (arglabels!!0) @@@ -347,7 -346,7 +347,7 @@@ genIterateOrGenerate' iter (Left res) -- -- temporary vector let tmp_ty = Var.varType res let error_msg = "\nGenerate.genFold': Can not construct temp vector for element type: " ++ pprString tmp_ty - tmp_vhdl_ty <- vhdl_ty error_msg tmp_ty + tmp_vhdl_ty <- MonadState.lift vsType $ vhdl_ty error_msg tmp_ty -- Setup the generate scheme let gen_label = mkVHDLExtId ("iterateVector" ++ (varToString start)) let block_label = mkVHDLExtId ("iterateVector" ++ (varToString res)) @@@ -421,7 -420,7 +421,7 @@@ genApplication dst f args -- It's a datacon. Create a record from its arguments. Left bndr -> do -- We have the bndr, so we can get at the type - labels <- getFieldLabels (Var.varType bndr) + labels <- MonadState.lift vsType $ getFieldLabels (Var.varType bndr) return $ zipWith mkassign labels $ map (either exprToVHDLExpr id) args where mkassign :: AST.VHDLId -> AST.Expr -> AST.ConcSm @@@ -465,7 -464,7 +465,7 @@@ -- Returns the VHDLId of the vector function with the given name for the given -- element type. Generates -- this function if needed. -vectorFunId :: Type.Type -> String -> VHDLSession AST.VHDLId +vectorFunId :: Type.Type -> String -> TypeSession AST.VHDLId vectorFunId el_ty fname = do let error_msg = "\nGenerate.vectorFunId: Can not construct vector function for element: " ++ pprString el_ty elemTM <- vhdl_ty error_msg el_ty @@@ -875,40 -874,40 +875,40 @@@ genUnconsVectorFuns elemTM vectorTM -- builder function. globalNameTable :: NameTable globalNameTable = Map.fromList - [ (exId , (2, genFCall ) ) - , (replaceId , (3, genFCall ) ) - , (headId , (1, genFCall ) ) - , (lastId , (1, genFCall ) ) - , (tailId , (1, genFCall ) ) - , (initId , (1, genFCall ) ) - , (takeId , (2, genFCall ) ) - , (dropId , (2, genFCall ) ) - , (selId , (4, genFCall ) ) - , (plusgtId , (2, genFCall ) ) - , (ltplusId , (2, genFCall ) ) - , (plusplusId , (2, genFCall ) ) + [ (exId , (2, genFCall False ) ) + , (replaceId , (3, genFCall False ) ) + , (headId , (1, genFCall True ) ) + , (lastId , (1, genFCall True ) ) + , (tailId , (1, genFCall False ) ) + , (initId , (1, genFCall False ) ) + , (takeId , (2, genFCall False ) ) + , (dropId , (2, genFCall False ) ) + , (selId , (4, genFCall False ) ) + , (plusgtId , (2, genFCall False ) ) + , (ltplusId , (2, genFCall False ) ) + , (plusplusId , (2, genFCall False ) ) , (mapId , (2, genMap ) ) , (zipWithId , (3, genZipWith ) ) , (foldlId , (3, genFoldl ) ) , (foldrId , (3, genFoldr ) ) , (zipId , (2, genZip ) ) , (unzipId , (1, genUnzip ) ) - , (shiftlId , (2, genFCall ) ) - , (shiftrId , (2, genFCall ) ) - , (rotlId , (1, genFCall ) ) - , (rotrId , (1, genFCall ) ) + , (shiftlId , (2, genFCall False ) ) + , (shiftrId , (2, genFCall False ) ) + , (rotlId , (1, genFCall False ) ) + , (rotrId , (1, genFCall False ) ) , (concatId , (1, genConcat ) ) - , (reverseId , (1, genFCall ) ) + , (reverseId , (1, genFCall False ) ) , (iteratenId , (3, genIteraten ) ) , (iterateId , (2, genIterate ) ) , (generatenId , (3, genGeneraten ) ) , (generateId , (2, genGenerate ) ) - , (emptyId , (0, genFCall ) ) - , (singletonId , (1, genFCall ) ) - , (copynId , (2, genFCall ) ) + , (emptyId , (0, genFCall False ) ) + , (singletonId , (1, genFCall False ) ) + , (copynId , (2, genFCall False ) ) , (copyId , (1, genCopy ) ) - , (lengthTId , (1, genFCall ) ) - , (nullId , (1, genFCall ) ) + , (lengthTId , (1, genFCall False ) ) + , (nullId , (1, genFCall False ) ) , (hwxorId , (2, genOperator2 AST.Xor ) ) , (hwandId , (2, genOperator2 AST.And ) ) , (hworId , (2, genOperator2 AST.Or ) ) diff --combined VHDLTools.hs index 5deaf45,cb4ea74..d560a74 --- a/VHDLTools.hs +++ b/VHDLTools.hs @@@ -2,7 -2,6 +2,7 @@@ module VHDLTools wher -- Standard modules import qualified Maybe +import qualified Data.Either as Either import qualified Data.List as List import qualified Data.Map as Map import qualified Control.Monad as Monad @@@ -263,89 -262,74 +263,90 @@@ builtin_types ] -- Translate a Haskell type to a VHDL type, generating a new type if needed. -vhdl_ty :: String -> Type.Type -> VHDLSession AST.TypeMark +-- Returns an error value, using the given message, when no type could be +-- created. +vhdl_ty :: String -> Type.Type -> TypeSession AST.TypeMark vhdl_ty msg ty = do + tm_either <- vhdl_ty_either ty + case tm_either of + Right tm -> return tm + Left err -> error $ msg ++ "\n" ++ err + +-- Translate a Haskell type to a VHDL type, generating a new type if needed. +-- Returns either an error message or the resulting type. +vhdl_ty_either :: Type.Type -> TypeSession (Either String AST.TypeMark) +vhdl_ty_either ty = do typemap <- getA vsTypes + htype <- mkHType ty let builtin_ty = do -- See if this is a tycon and lookup its name (tycon, args) <- Type.splitTyConApp_maybe ty let name = Name.getOccString (TyCon.tyConName tycon) Map.lookup name builtin_types -- If not a builtin type, try the custom types - let existing_ty = (fmap fst) $ Map.lookup (OrdType ty) typemap + let existing_ty = (fmap fst) $ Map.lookup htype typemap case Monoid.getFirst $ Monoid.mconcat (map Monoid.First [builtin_ty, existing_ty]) of -- Found a type, return it - Just t -> return t + Just t -> return (Right t) -- No type yet, try to construct it Nothing -> do - newty_maybe <- (construct_vhdl_ty msg ty) + newty_maybe <- (construct_vhdl_ty ty) case newty_maybe of - Just (ty_id, ty_def) -> do + Right (ty_id, ty_def) -> do -- TODO: Check name uniqueness - modA vsTypes (Map.insert (OrdType ty) (ty_id, ty_def)) + modA vsTypes (Map.insert htype (ty_id, ty_def)) modA vsTypeDecls (\typedefs -> typedefs ++ [mktydecl (ty_id, ty_def)]) - return ty_id - Nothing -> error $ msg ++ "\nVHDLTools.vhdl_ty: Unsupported Haskell type: " ++ pprString ty ++ "\n" - --- Construct a new VHDL type for the given Haskell type. -construct_vhdl_ty :: String -> Type.Type -> VHDLSession (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn)) -construct_vhdl_ty msg ty = do + return (Right ty_id) + Left err -> return $ Left $ + "VHDLTools.vhdl_ty: Unsupported Haskell type: " ++ pprString ty ++ "\n" + ++ err + +-- Construct a new VHDL type for the given Haskell type. Returns an error +-- message or the resulting typemark and typedef. +construct_vhdl_ty :: Type.Type -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn)) +construct_vhdl_ty ty = do case Type.splitTyConApp_maybe ty of Just (tycon, args) -> do let name = Name.getOccString (TyCon.tyConName tycon) case name of - "TFVec" -> do - res <- mk_vector_ty ty - return $ Just $ (Arrow.second Right) res + "TFVec" -> mk_vector_ty ty -- "SizedWord" -> do -- res <- mk_vector_ty (sized_word_len ty) ty -- return $ Just $ (Arrow.second Left) res - "RangedWord" -> do - res <- mk_natural_ty 0 (ranged_word_bound ty) - return $ Just $ (Arrow.second Right) res + "RangedWord" -> mk_natural_ty 0 (ranged_word_bound ty) -- Create a custom type from this tycon - otherwise -> mk_tycon_ty msg tycon args - Nothing -> return $ Nothing + otherwise -> mk_tycon_ty tycon args + Nothing -> return (Left $ "VHDLTools.construct_vhdl_ty: Cannot create type for non-tycon type: " ++ pprString ty ++ "\n") -- | Create VHDL type for a custom tycon -mk_tycon_ty :: String -> TyCon.TyCon -> [Type.Type] -> VHDLSession (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn)) -mk_tycon_ty msg tycon args = +mk_tycon_ty :: TyCon.TyCon -> [Type.Type] -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn)) +mk_tycon_ty tycon args = case TyCon.tyConDataCons tycon of -- Not an algebraic type - [] -> error $ "\nVHDLTools.mk_tycon_ty: Only custom algebraic types are supported: " ++ pprString tycon + [] -> return (Left $ "VHDLTools.mk_tycon_ty: Only custom algebraic types are supported: " ++ pprString tycon ++ "\n") [dc] -> do let arg_tys = DataCon.dataConRepArgTys dc -- TODO: CoreSubst docs say each Subs can be applied only once. Is this a -- violation? Or does it only mean not to apply it again to the same -- subject? let real_arg_tys = map (CoreSubst.substTy subst) arg_tys - let error_msg = msg ++ "\nVHDLTools.mk_tycon_ty: Can not construct type for: " ++ pprString tycon ++ "\n because no type can be construced for one of the arguments." - elem_tys <- mapM (vhdl_ty error_msg) real_arg_tys - let elems = zipWith AST.ElementDec recordlabels elem_tys - -- For a single construct datatype, build a record with one field for - -- each argument. - -- TODO: Add argument type ids to this, to ensure uniqueness - -- TODO: Special handling for tuples? - let elem_names = concat $ map prettyShow elem_tys - let ty_id = mkVHDLExtId $ nameToString (TyCon.tyConName tycon) ++ elem_names - let ty_def = AST.TDR $ AST.RecordTypeDef elems - return $ Just (ty_id, Left ty_def) - dcs -> error $ "\nVHDLTools.mk_tycon_ty: Only single constructor datatypes supported: " ++ pprString tycon + elem_tys_either <- mapM vhdl_ty_either real_arg_tys + case Either.partitionEithers elem_tys_either of + -- No errors in element types + ([], elem_tys) -> do + let elems = zipWith AST.ElementDec recordlabels elem_tys + -- For a single construct datatype, build a record with one field for + -- each argument. + -- TODO: Add argument type ids to this, to ensure uniqueness + -- TODO: Special handling for tuples? + let elem_names = concat $ map prettyShow elem_tys + let ty_id = mkVHDLExtId $ nameToString (TyCon.tyConName tycon) ++ elem_names + let ty_def = AST.TDR $ AST.RecordTypeDef elems + return $ Right (ty_id, Left ty_def) + -- There were errors in element types + (errors, _) -> return $ Left $ + "VHDLTools.mk_tycon_ty: Can not construct type for: " ++ pprString tycon ++ "\n because no type can be construced for some of the arguments.\n" + ++ (concat errors) + dcs -> return $ Left $ "VHDLTools.mk_tycon_ty: Only single constructor datatypes supported: " ++ pprString tycon ++ "\n" where -- Create a subst that instantiates all types passed to the tycon -- TODO: I'm not 100% sure that this is the right way to do this. It seems @@@ -358,8 -342,7 +359,8 @@@ -- | Create a VHDL vector type mk_vector_ty :: Type.Type -- ^ The Haskell type of the Vector - -> VHDLSession (AST.TypeMark, AST.SubtypeIn) -- The typemark created. + -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn)) + -- ^ An error message or The typemark created. mk_vector_ty ty = do types_map <- getA vsTypes @@@ -368,53 -351,85 +369,92 @@@ let vec_ty = Type.mkAppTy nvec nvec_el let len = tfvec_len ty let el_ty = tfvec_elem ty - let error_msg = "\nVHDLTools.mk_vector_ty: Can not construct vectortype for elementtype: " ++ pprString el_ty - el_ty_tm <- vhdl_ty error_msg el_ty - let ty_id = mkVHDLExtId $ "vector-"++ (AST.fromVHDLId el_ty_tm) ++ "-0_to_" ++ (show len) - let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len - 1))] - let existing_elem_ty = (fmap fst) $ Map.lookup (StdType $ OrdType vec_ty) types_map - case existing_elem_ty of - Just t -> do - let ty_def = AST.SubtypeIn t (Just range) - return (ty_id, ty_def) - Nothing -> do - let vec_id = mkVHDLExtId $ "vector_" ++ (AST.fromVHDLId el_ty_tm) - let vec_def = AST.TDA $ AST.UnconsArrayDef [tfvec_indexTM] el_ty_tm - modA vsTypes (Map.insert (StdType $ OrdType vec_ty) (vec_id, (Left vec_def))) - modA vsTypeDecls (\typedefs -> typedefs ++ [mktydecl (vec_id, (Left vec_def))]) - let ty_def = AST.SubtypeIn vec_id (Just range) - return (ty_id, ty_def) + el_ty_tm_either <- vhdl_ty_either el_ty + case el_ty_tm_either of + -- Could create element type + Right el_ty_tm -> do + let ty_id = mkVHDLExtId $ "vector-"++ (AST.fromVHDLId el_ty_tm) ++ "-0_to_" ++ (show len) + let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len - 1))] - let existing_elem_ty = (fmap fst) $ Map.lookup (OrdType vec_ty) types_map ++ let existing_elem_ty = (fmap fst) $ Map.lookup (StdType $ OrdType vec_ty) types_map + case existing_elem_ty of + Just t -> do + let ty_def = AST.SubtypeIn t (Just range) + return (Right (ty_id, Right ty_def)) + Nothing -> do + let vec_id = mkVHDLExtId $ "vector_" ++ (AST.fromVHDLId el_ty_tm) + let vec_def = AST.TDA $ AST.UnconsArrayDef [tfvec_indexTM] el_ty_tm - modA vsTypes (Map.insert (OrdType vec_ty) (vec_id, (Left vec_def))) ++ modA vsTypes (Map.insert (StdType $ OrdType vec_ty) (vec_id, (Left vec_def))) + modA vsTypeDecls (\typedefs -> typedefs ++ [mktydecl (vec_id, (Left vec_def))]) + let ty_def = AST.SubtypeIn vec_id (Just range) + return (Right (ty_id, Right ty_def)) + -- Could not create element type + Left err -> return $ Left $ + "VHDLTools.mk_vector_ty: Can not construct vectortype for elementtype: " ++ pprString el_ty ++ "\n" + ++ err mk_natural_ty :: Int -- ^ The minimum bound (> 0) -> Int -- ^ The maximum bound (> minimum bound) - -> VHDLSession (AST.TypeMark, AST.SubtypeIn) -- The typemark created. + -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn)) + -- ^ An error message or The typemark created. mk_natural_ty min_bound max_bound = do let ty_id = mkVHDLExtId $ "nat_" ++ (show min_bound) ++ "_to_" ++ (show max_bound) let range = AST.ConstraintRange $ AST.SubTypeRange (AST.PrimLit $ (show min_bound)) (AST.PrimLit $ (show max_bound)) let ty_def = AST.SubtypeIn naturalTM (Just range) - return (ty_id, ty_def) + return (Right (ty_id, Right ty_def)) -- Finds the field labels for VHDL type generated for the given Core type, -- which must result in a record type. -getFieldLabels :: Type.Type -> VHDLSession [AST.VHDLId] +getFieldLabels :: Type.Type -> TypeSession [AST.VHDLId] getFieldLabels ty = do -- Ensure that the type is generated (but throw away it's VHDLId) let error_msg = "\nVHDLTools.getFieldLabels: Can not get field labels, because: " ++ pprString ty ++ "can not be generated." vhdl_ty error_msg ty -- Get the types map, lookup and unpack the VHDL TypeDef types <- getA vsTypes - case Map.lookup (OrdType ty) types of + htype <- mkHType ty + case Map.lookup htype types of Just (_, Left (AST.TDR (AST.RecordTypeDef elems))) -> return $ map (\(AST.ElementDec id _) -> id) elems _ -> error $ "\nVHDL.getFieldLabels: Type not found or not a record type? This should not happen! Type: " ++ (show ty) mktydecl :: (AST.VHDLId, Either AST.TypeDef AST.SubtypeIn) -> AST.PackageDecItem mktydecl (ty_id, Left ty_def) = AST.PDITD $ AST.TypeDec ty_id ty_def mktydecl (ty_id, Right ty_def) = AST.PDISD $ AST.SubtypeDec ty_id ty_def + -mkHType :: Type.Type -> VHDLSession HType ++mkHType :: Type.Type -> TypeSession HType + mkHType ty = do + -- FIXME: Do we really need to do this here again? + let builtin_ty = do -- See if this is a tycon and lookup its name + (tycon, args) <- Type.splitTyConApp_maybe ty + let name = Name.getOccString (TyCon.tyConName tycon) + Map.lookup name builtin_types + case builtin_ty of + Just typ -> + return $ BuiltinType $ prettyShow typ + Nothing -> + case Type.splitTyConApp_maybe ty of + Just (tycon, args) -> do + let name = Name.getOccString (TyCon.tyConName tycon) + case name of + "TFVec" -> do + elem_htype <- mkHType (tfvec_elem ty) + return $ VecType (tfvec_len ty) elem_htype + otherwise -> do + mkTyConHType tycon args + Nothing -> return $ StdType $ OrdType ty + + -- FIXME: Do we really need to do this here again? -mkTyConHType :: TyCon.TyCon -> [Type.Type] -> VHDLSession HType ++mkTyConHType :: TyCon.TyCon -> [Type.Type] -> TypeSession HType + mkTyConHType tycon args = + case TyCon.tyConDataCons tycon of + -- Not an algebraic type + [] -> error $ "\nVHDLTools.mkHType: Only custom algebraic types are supported: " ++ pprString tycon + [dc] -> do + let arg_tys = DataCon.dataConRepArgTys dc + let real_arg_tys = map (CoreSubst.substTy subst) arg_tys + elem_htys <- mapM mkHType real_arg_tys + return $ ADTType (nameToString (TyCon.tyConName tycon)) elem_htys + dcs -> error $ "\nVHDLTools.mkHType: Only single constructor datatypes supported: " ++ pprString tycon + where + tyvars = TyCon.tyConTyVars tycon - subst = CoreSubst.extendTvSubstList CoreSubst.emptySubst (zip tyvars args) ++ subst = CoreSubst.extendTvSubstList CoreSubst.emptySubst (zip tyvars args) diff --combined VHDLTypes.hs index 0a81b7b,4a1b017..ff159fa --- a/VHDLTypes.hs +++ b/VHDLTypes.hs @@@ -38,8 -38,14 +38,14 @@@ instance Eq OrdType wher instance Ord OrdType where compare (OrdType a) (OrdType b) = Type.tcCmpType a b + data HType = StdType OrdType | + ADTType String [HType] | + VecType Int HType | + BuiltinType String + deriving (Eq, Ord) + -- A map of a Core type to the corresponding type name - type TypeMap = Map.Map OrdType (AST.VHDLId, Either AST.TypeDef AST.SubtypeIn) + type TypeMap = Map.Map HType (AST.VHDLId, Either AST.TypeDef AST.SubtypeIn) -- A map of a vector Core element type and function name to the coressponding -- VHDLId of the function and the function body. @@@ -48,24 -54,13 +54,24 @@@ type TypeFunMap = Map.Map (OrdType, Str -- A map of a Haskell function to a hardware signature type SignatureMap = Map.Map CoreSyn.CoreBndr Entity -data VHDLState = VHDLState { +data TypeState = TypeState { -- | A map of Core type -> VHDL Type vsTypes_ :: TypeMap, -- | A list of type declarations vsTypeDecls_ :: [AST.PackageDecItem], -- | A map of vector Core type -> VHDL type function - vsTypeFuns_ :: TypeFunMap, + vsTypeFuns_ :: TypeFunMap +} +-- Derive accessors +$( Data.Accessor.Template.deriveAccessors ''TypeState ) +-- Define an empty TypeState +emptyTypeState = TypeState Map.empty [] Map.empty +-- Define a session +type TypeSession = State.State TypeState + +data VHDLState = VHDLState { + -- | A subtype with typing info + vsType_ :: TypeState, -- | A map of HsFunction -> hardware signature (entity name, port names, -- etc.) vsSignatures_ :: SignatureMap @@@ -77,6 -72,9 +83,6 @@@ $( Data.Accessor.Template.deriveAccesso -- | The state containing a VHDL Session type VHDLSession = State.State VHDLState --- | A substate containing just the types -type TypeState = State.State TypeMap - -- A function that generates VHDL for a builtin function type BuiltinBuilder = (Either CoreSyn.CoreBndr AST.VHDLName) -- ^ The destination signal and it's original type