From: Matthijs Kooijman Date: Fri, 3 Jul 2009 11:10:05 +0000 (+0200) Subject: Split off the type related VHDLState variables. X-Git-Url: https://git.stderr.nl/gitweb?a=commitdiff_plain;ds=inline;h=afd269e5653952394495a7a14ad1bfc0c0146b39;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git Split off the type related VHDLState variables. These are now put in a substate of VHDLState, named TypeState. This allows a TypeState to be put into TransformState later on as well. --- diff --git a/Generate.hs b/Generate.hs index 55f0156..6b19bb5 100644 --- a/Generate.hs +++ b/Generate.hs @@ -6,6 +6,7 @@ import qualified Data.Map as Map import qualified Maybe import qualified Data.Either as Either import Data.Accessor +import Data.Accessor.MonadState as MonadState import Debug.Trace -- ForSyDe @@ -77,7 +78,7 @@ genFCall' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Ex genFCall' (Left res) f args = do let fname = varToString f let el_ty = (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 @@ -155,7 +156,7 @@ genFold' left (Left res) f [folded_f, start, vec] = do -- 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)) @@ -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 @@ -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) @@ -346,7 +347,7 @@ genIterateOrGenerate' iter (Left res) f [app_f, start] = do -- -- 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)) @@ -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 @@ -464,7 +465,7 @@ genApplication dst f args = -- 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 diff --git a/VHDL.hs b/VHDL.hs index 13a9294..daf843f 100644 --- a/VHDL.hs +++ b/VHDL.hs @@ -12,6 +12,7 @@ import qualified Control.Arrow as Arrow import qualified Control.Monad.Trans.State as State import qualified Data.Monoid as Monoid import Data.Accessor +import Data.Accessor.MonadState as MonadState import Debug.Trace -- ForSyDe @@ -47,11 +48,11 @@ createDesignFiles binds = map (Arrow.second $ AST.DesignFile full_context) units where - init_session = VHDLState Map.empty [] Map.empty Map.empty + init_session = VHDLState emptyTypeState Map.empty (units, final_session) = State.runState (createLibraryUnits binds) init_session - tyfun_decls = map snd $ Map.elems (final_session ^.vsTypeFuns) - ty_decls = final_session ^.vsTypeDecls + tyfun_decls = map snd $ Map.elems (final_session ^. vsType ^. vsTypeFuns) + ty_decls = final_session ^. vsType ^. vsTypeDecls tfvec_index_decl = AST.PDISD $ AST.SubtypeDec tfvec_indexTM tfvec_index_def tfvec_range = AST.ConstraintRange $ AST.SubTypeRange (AST.PrimLit "-1") (AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerTM) highId Nothing) tfvec_index_def = AST.SubtypeIn integerTM (Just tfvec_range) @@ -127,7 +128,7 @@ createEntity (fname, expr) = do ty = Var.varType bndr error_msg = "\nVHDL.createEntity.mkMap: Can not create entity: " ++ pprString fname ++ "\nbecause no type can be created for port: " ++ pprString bndr in do - type_mark <- vhdl_ty error_msg ty + type_mark <- MonadState.lift vsType $ vhdl_ty error_msg ty return (id, type_mark) ) @@ -237,7 +238,7 @@ mkSigDec :: CoreSyn.CoreBndr -> VHDLSession (Maybe AST.SigDec) mkSigDec bndr = if True then do --isInternalSigUse use || isStateSigUse use then do let error_msg = "\nVHDL.mkSigDec: Can not make signal declaration for type: \n" ++ pprString bndr - type_mark <- (vhdl_ty error_msg) $ Var.varType bndr + type_mark <- MonadState.lift vsType $ vhdl_ty error_msg (Var.varType bndr) return $ Just (AST.SigDec (varToVHDLId bndr) type_mark Nothing) else return Nothing @@ -271,7 +272,7 @@ mkConcSm (bndr, expr@(Case (Var scrut) b ty [alt])) = (DataAlt dc, bndrs, (Var sel_bndr)) -> do case List.elemIndex sel_bndr bndrs of Just i -> do - labels <- getFieldLabels (Id.idType scrut) + labels <- MonadState.lift vsType $ getFieldLabels (Id.idType scrut) let label = labels!!i let sel_name = mkSelectedName (varToVHDLName scrut) label let sel_expr = AST.PrimName sel_name diff --git a/VHDLTools.hs b/VHDLTools.hs index ad593d9..5deaf45 100644 --- a/VHDLTools.hs +++ b/VHDLTools.hs @@ -265,7 +265,7 @@ builtin_types = -- Translate a Haskell type to a VHDL type, generating a new type if needed. -- Returns an error value, using the given message, when no type could be -- created. -vhdl_ty :: String -> Type.Type -> VHDLSession AST.TypeMark +vhdl_ty :: String -> Type.Type -> TypeSession AST.TypeMark vhdl_ty msg ty = do tm_either <- vhdl_ty_either ty case tm_either of @@ -274,7 +274,7 @@ vhdl_ty msg ty = do -- 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 -> VHDLSession (Either String AST.TypeMark) +vhdl_ty_either :: Type.Type -> TypeSession (Either String AST.TypeMark) vhdl_ty_either ty = do typemap <- getA vsTypes let builtin_ty = do -- See if this is a tycon and lookup its name @@ -301,7 +301,7 @@ vhdl_ty_either ty = do -- 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 -> VHDLSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn)) +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 @@ -317,7 +317,7 @@ construct_vhdl_ty ty = do 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 :: TyCon.TyCon -> [Type.Type] -> VHDLSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn)) +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 @@ -358,7 +358,7 @@ mk_tycon_ty tycon args = -- | Create a VHDL vector type mk_vector_ty :: Type.Type -- ^ The Haskell type of the Vector - -> VHDLSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn)) + -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn)) -- ^ An error message or The typemark created. mk_vector_ty ty = do @@ -394,7 +394,7 @@ mk_vector_ty ty = do mk_natural_ty :: Int -- ^ The minimum bound (> 0) -> Int -- ^ The maximum bound (> minimum bound) - -> VHDLSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn)) + -> 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) @@ -404,7 +404,7 @@ mk_natural_ty min_bound max_bound = do -- 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." diff --git a/VHDLTypes.hs b/VHDLTypes.hs index 61fb003..0a81b7b 100644 --- a/VHDLTypes.hs +++ b/VHDLTypes.hs @@ -48,13 +48,24 @@ type TypeFunMap = Map.Map (OrdType, String) (AST.VHDLId, AST.SubProgBody) -- 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 @@ -66,9 +77,6 @@ $( Data.Accessor.Template.deriveAccessors ''VHDLState ) -- | 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