From: Matthijs Kooijman Date: Tue, 10 Mar 2009 14:42:38 +0000 (+0100) Subject: Redo the global (state) structure of the translator. X-Git-Url: https://git.stderr.nl/gitweb?a=commitdiff_plain;h=d8c4021114afc1f860763b3a8dceff3f219d4798;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git Redo the global (state) structure of the translator. This gives the VHDL module its own state and moves the Entity for each function into that state. The AST.EntityDec and AST.ArchBody are no longer stored in the state, but simply returned directly. The State class used is changed from the one from the mtl library to the one from the transformers library, since that one integrates nicely with the data-accessors library. This integration (together with the simplification of the states) pretty much removes the need for all manually defined accessor function. This change breaks support for builtin functions (hwxor, hwnot, etc.), which will be fixed in a subsequent commit. Also, custom types are not longer output right now, but there is infrastructure in place to do better type collection. --- diff --git a/Flatten.hs b/Flatten.hs index 4bb6e71..8adce9f 100644 --- a/Flatten.hs +++ b/Flatten.hs @@ -15,7 +15,7 @@ import qualified Data.Traversable as Traversable import qualified Data.Foldable as Foldable import Control.Applicative import Outputable ( showSDoc, ppr ) -import qualified Control.Monad.State as State +import qualified Control.Monad.Trans.State as State import HsValueMap import TranslatorTypes @@ -222,7 +222,7 @@ flattenExpr binds app@(App _ _) = do flattenBuildTupleExpr binds args = do -- Flatten each of our args - flat_args <- (State.mapM (flattenExpr binds) args) + flat_args <- (mapM (flattenExpr binds) args) -- Check and split each of the arguments let (_, arg_ress) = unzip (zipWith checkArg args flat_args) let res = Tuple arg_ress @@ -233,7 +233,7 @@ flattenExpr binds app@(App _ _) = do -- Find the function to call let func = appToHsFunction ty f args -- Flatten each of our args - flat_args <- (State.mapM (flattenExpr binds) args) + flat_args <- (mapM (flattenExpr binds) args) -- Check and split each of the arguments let (_, arg_ress) = unzip (zipWith checkArg args flat_args) -- Generate signals for our result diff --git a/FlattenTypes.hs b/FlattenTypes.hs index 785704d..f20fbc3 100644 --- a/FlattenTypes.hs +++ b/FlattenTypes.hs @@ -3,7 +3,7 @@ module FlattenTypes where import qualified Maybe import Data.Traversable import qualified Data.Foldable as Foldable -import qualified Control.Monad.State as State +import qualified Control.Monad.Trans.State as State import CoreSyn import qualified Type diff --git a/Pretty.hs b/Pretty.hs index edfe05b..43e0e49 100644 --- a/Pretty.hs +++ b/Pretty.hs @@ -97,15 +97,15 @@ instance Pretty SigUse where pPrint SigSubState = text "s" instance Pretty TranslatorSession where - pPrint (VHDLSession mod nameCount funcs) = + pPrint (TranslatorSession mod nameCount flatfuncs) = text "Module: " $$ nest 15 (text modname) $+$ text "NameCount: " $$ nest 15 (int nameCount) - $+$ text "Functions: " $$ nest 15 (vcat (map ppfunc (Map.toList funcs))) + $+$ text "Functions: " $$ nest 15 (vcat (map ppfunc (Map.toList flatfuncs))) where - ppfunc (hsfunc, fdata) = - pPrint hsfunc $+$ nest 5 (pPrint fdata) + ppfunc (hsfunc, flatfunc) = + pPrint hsfunc $+$ nest 5 (pPrint flatfunc) modname = showSDoc $ Module.pprModule (HscTypes.cm_module mod) - +{- instance Pretty FuncData where pPrint (FuncData flatfunc entity arch) = text "Flattened: " $$ nest 15 (ppffunc flatfunc) @@ -118,19 +118,13 @@ instance Pretty FuncData where ppent Nothing = text "Nothing" pparch Nothing = text "VHDL architecture not present" pparch (Just _) = text "VHDL architecture present" +-} instance Pretty Entity where - pPrint (Entity id args res decl pkg) = + pPrint (Entity id args res) = text "Entity: " $$ nest 10 (pPrint id) $+$ text "Args: " $$ nest 10 (pPrint args) $+$ text "Result: " $$ nest 10 (pPrint res) - $+$ ppdecl decl - $+$ pppkg pkg - where - ppdecl Nothing = text "VHDL entity not present" - ppdecl (Just _) = text "VHDL entity present" - pppkg Nothing = text "VHDL package not present" - pppkg (Just _) = text "VHDL package present" instance (OutputableBndr b, Show b) => Pretty (CoreSyn.Bind b) where pPrint (CoreSyn.NonRec b expr) = diff --git a/Translator.hs b/Translator.hs index aa8d0d9..1ecbdb9 100644 --- a/Translator.hs +++ b/Translator.hs @@ -10,8 +10,8 @@ import qualified TyCon import qualified DataCon import qualified Maybe import qualified Module -import qualified Control.Monad.State as State import qualified Data.Foldable as Foldable +import qualified Control.Monad.Trans.State as State import Name import qualified Data.Map as Map import Data.Accessor @@ -73,44 +73,38 @@ listBind filename name = do -- | Translate the binds with the given names from the given core module to -- VHDL. The Bool in the tuple makes the function stateful (True) or -- stateless (False). -moduleToVHDL :: HscTypes.CoreModule -> [(String, Bool)] -> IO [AST.DesignFile] +moduleToVHDL :: HscTypes.CoreModule -> [(String, Bool)] -> IO [(AST.VHDLId, AST.DesignFile)] moduleToVHDL core list = do let (names, statefuls) = unzip list --liftIO $ putStr $ prettyShow (cm_binds core) let binds = findBinds core names --putStr $ prettyShow binds -- Turn bind into VHDL - let (vhdl, sess) = State.runState (mkVHDL binds statefuls) (VHDLSession core 0 Map.empty) - mapM (putStr . render . ForSyDe.Backend.Ppr.ppr) vhdl + let (vhdl, sess) = State.runState (mkVHDL binds statefuls) (TranslatorSession core 0 Map.empty) + mapM (putStr . render . ForSyDe.Backend.Ppr.ppr . snd) vhdl putStr $ "\n\nFinal session:\n" ++ prettyShow sess ++ "\n\n" return vhdl - where -- Turns the given bind into VHDL + mkVHDL :: [CoreBind] -> [Bool] -> TranslatorState [(AST.VHDLId, AST.DesignFile)] mkVHDL binds statefuls = do -- Add the builtin functions - mapM addBuiltIn builtin_funcs + --mapM addBuiltIn builtin_funcs -- Create entities and architectures for them Monad.zipWithM processBind statefuls binds - modFuncMap $ Map.map (fdFlatFunc ^: (fmap nameFlatFunction)) - modFuncMap $ Map.mapWithKey (\hsfunc fdata -> fdEntity ^= (VHDL.createEntity hsfunc fdata) $ fdata) - funcs <- getFuncMap - modFuncMap $ Map.mapWithKey (\hsfunc fdata -> fdArch ^= (VHDL.createArchitecture funcs hsfunc fdata) $ fdata) - funcs <- getFuncs - return $ VHDL.getDesignFiles (map snd funcs) - --- | Write the given design file to a file inside the given dir --- The first library unit in the designfile must be an entity, whose name --- will be used as a filename. -writeVHDL :: String -> AST.DesignFile -> IO () -writeVHDL dir vhdl = do + modA tsFlatFuncs (Map.map nameFlatFunction) + flatfuncs <- getA tsFlatFuncs + return $ VHDL.createDesignFiles flatfuncs + +-- | Write the given design file to a file with the given name inside the +-- given dir +writeVHDL :: String -> (AST.VHDLId, AST.DesignFile) -> IO () +writeVHDL dir (name, vhdl) = do -- Create the dir if needed exists <- Directory.doesDirectoryExist dir Monad.unless exists $ Directory.createDirectory dir -- Find the filename - let AST.DesignFile _ (u:us) = vhdl - let AST.LUEntity (AST.EntityDec id _) = u - let fname = dir ++ AST.fromVHDLId id ++ ".vhdl" + let fname = dir ++ (AST.fromVHDLId name) ++ ".vhdl" -- Write the file ForSyDe.Backend.VHDL.FileIO.writeDesignFile vhdl fname @@ -169,18 +163,15 @@ flattenBind :: flattenBind _ (Rec _) = error "Recursive binders not supported" flattenBind hsfunc bind@(NonRec var expr) = do - -- Add the function to the session - addFunc hsfunc -- Flatten the function let flatfunc = flattenFunction hsfunc bind -- Propagate state variables let flatfunc' = propagateState hsfunc flatfunc -- Store the flat function in the session - setFlatFunc hsfunc flatfunc' + modA tsFlatFuncs (Map.insert hsfunc flatfunc) -- Flatten any functions used let used_hsfuncs = Maybe.mapMaybe usedHsFunc (flat_defs flatfunc') - State.mapM resolvFunc used_hsfuncs - return () + mapM_ resolvFunc used_hsfuncs -- | Decide which incoming state variables will become state in the -- given function, and which will be propagate to other applied @@ -276,23 +267,18 @@ resolvFunc :: -> TranslatorState () resolvFunc hsfunc = do - -- See if the function is already known - func <- getFunc hsfunc - case func of - -- Already known, do nothing - Just _ -> do - return () - -- New function, resolve it - Nothing -> do - -- Get the current module - core <- getModule - -- Find the named function - let bind = findBind (cm_binds core) name - case bind of - Nothing -> error $ "Couldn't find function " ++ name ++ " in current module." - Just b -> flattenBind hsfunc b - where - name = hsFuncName hsfunc + flatfuncmap <- getA tsFlatFuncs + -- Don't do anything if there is already a flat function for this hsfunc. + Monad.unless (Map.member hsfunc flatfuncmap) $ do + -- TODO: Builtin functions + -- New function, resolve it + core <- getA tsCoreModule + -- Find the named function + let name = (hsFuncName hsfunc) + let bind = findBind (cm_binds core) name + case bind of + Nothing -> error $ "Couldn't find function " ++ name ++ " in current module." + Just b -> flattenBind hsfunc b -- | Translate a top level function declaration to a HsFunction. i.e., which -- interface will be provided by this function. This function essentially @@ -378,6 +364,7 @@ toVHDLSignalMap = fmap (\(name, ty) -> Just (VHDL.mkVHDLId name, ty)) -- | Translate a concise representation of a builtin function to something -- that can be put into FuncMap directly. +{- addBuiltIn :: BuiltIn -> TranslatorState () addBuiltIn (BuiltIn name args res) = do addFunc hsfunc @@ -393,5 +380,5 @@ builtin_funcs = BuiltIn "hwor" [(Single ("a", VHDL.bit_ty)), (Single ("b", VHDL.bit_ty))] (Single ("o", VHDL.bit_ty)), BuiltIn "hwnot" [(Single ("a", VHDL.bit_ty))] (Single ("o", VHDL.bit_ty)) ] - +-} -- vim: set ts=8 sw=2 sts=2 expandtab: diff --git a/TranslatorTypes.hs b/TranslatorTypes.hs index fdd0e34..37e8619 100644 --- a/TranslatorTypes.hs +++ b/TranslatorTypes.hs @@ -5,7 +5,7 @@ {-# LANGUAGE TemplateHaskell #-} module TranslatorTypes where -import qualified Control.Monad.State as State +import qualified Control.Monad.Trans.State as State import qualified Data.Map as Map import qualified Data.Accessor.Template import Data.Accessor @@ -21,105 +21,17 @@ import HsValueMap -- | A map from a HsFunction identifier to various stuff we collect about a -- function along the way. -type FuncMap = Map.Map HsFunction FuncData +type FlatFuncMap = Map.Map HsFunction FlatFunction --- | Some stuff we collect about a function along the way. -data FuncData = FuncData { - fdFlatFunc_ :: Maybe FlatFunction, - fdEntity_ :: Maybe Entity, - fdArch_ :: Maybe AST.ArchBody -} deriving (Show) +data TranslatorSession = TranslatorSession { + tsCoreModule_ :: HscTypes.CoreModule, -- ^ The current module + tsNameCount_ :: Int, -- ^ A counter that can be used to generate unique names + tsFlatFuncs_ :: FlatFuncMap -- ^ A map from HsFunction to FlatFunction +} -- Derive accessors -$( Data.Accessor.Template.deriveAccessors ''FuncData ) - -data TranslatorSession = VHDLSession { - coreMod :: HscTypes.CoreModule, -- The current module - nameCount :: Int, -- A counter that can be used to generate unique names - funcs :: FuncMap -- A map from HsFunction to FlatFunction, HWFunction, VHDL Entity and Architecture -} +$( Data.Accessor.Template.deriveAccessors ''TranslatorSession ) type TranslatorState = State.State TranslatorSession --- | Add the function to the session -addFunc :: HsFunction -> TranslatorState () -addFunc hsfunc = - modFuncMap (Map.insert hsfunc (FuncData Nothing Nothing Nothing)) - --- | Find the given function in the current session -getFunc :: HsFunction -> TranslatorState (Maybe FuncData) -getFunc hsfunc = do - fs <- State.gets funcs -- Get the funcs element from the session - return $ Map.lookup hsfunc fs - --- | Gets all functions from the current session -getFuncs :: TranslatorState [(HsFunction, FuncData)] -getFuncs = do - fs <- State.gets funcs -- Get the funcs element from the session - return $ Map.toList fs - --- | Gets all the functions from the current session -getHsFuncs :: TranslatorState [HsFunction] -getHsFuncs = do - fs <- State.gets funcs -- Get the funcs element from the session - return $ Map.keys fs - --- | Sets the FlatFunction for the given HsFunction in the current session. -setFlatFunc :: HsFunction -> FlatFunction -> TranslatorState () -setFlatFunc hsfunc flatfunc = - modFunc (fdFlatFunc ^= Just flatfunc) hsfunc - --- | Sets the Entity for the given HsFunction in the current session. -setEntity :: HsFunction -> Entity -> TranslatorState () -setEntity hsfunc entity = - modFunc (fdEntity ^= Just entity) hsfunc - --- | Sets the Entity for the given HsFunction in the current session. -setArchitecture :: HsFunction -> AST.ArchBody -> TranslatorState () -setArchitecture hsfunc arch = - modFunc (fdArch ^= Just arch) hsfunc - --- | Modify a function in the map using the given function -modFunc :: (FuncData -> FuncData) -> HsFunction -> TranslatorState () -modFunc f hsfunc = - modFuncMap (Map.adjust f hsfunc) - --- | Get the map of functions in the session -getFuncMap :: TranslatorState FuncMap -getFuncMap = State.gets funcs - --- | Modify the function map in the session using the given function -modFuncMap :: (FuncMap -> FuncMap) -> TranslatorState () -modFuncMap f = do - fs <- State.gets funcs -- Get the funcs element from the session - let fs' = f fs - State.modify (\x -> x {funcs = fs' }) - --- | Apply the given function to all functions in the map, and collect the --- results. The function is allowed to change the function map in the --- session, but any new functions added will not be mapped. -modFuncs :: (HsFunction -> FuncData -> TranslatorState ()) -> TranslatorState () -modFuncs f = do - hsfuncs <- getHsFuncs - mapM doFunc hsfuncs - return () - where - doFunc hsfunc = do - fdata_maybe <- getFunc hsfunc - case fdata_maybe of - Nothing -> do return () - Just fdata -> f hsfunc fdata - -getModule :: TranslatorState HscTypes.CoreModule -getModule = State.gets coreMod -- Get the coreMod element from the session - --- Makes the given name unique by appending a unique number. --- This does not do any checking against existing names, so it only guarantees --- uniqueness with other names generated by uniqueName. -uniqueName :: String -> TranslatorState String -uniqueName name = do - count <- State.gets nameCount -- Get the funcs element from the session - State.modify (\s -> s {nameCount = count + 1}) - return $ name ++ "_" ++ (show count) - -- vim: set ts=8 sw=2 sts=2 expandtab: diff --git a/VHDL.hs b/VHDL.hs index 418ac18..9a51c7a 100644 --- a/VHDL.hs +++ b/VHDL.hs @@ -9,6 +9,7 @@ import qualified Data.Map as Map import qualified Maybe import qualified Control.Monad as Monad import qualified Control.Arrow as Arrow +import qualified Control.Monad.Trans.State as State import qualified Data.Traversable as Traversable import qualified Data.Monoid as Monoid import Data.Accessor @@ -27,28 +28,44 @@ import FlattenTypes import TranslatorTypes import Pretty -getDesignFiles :: [FuncData] -> [AST.DesignFile] -getDesignFiles funcs = - map (AST.DesignFile context) units +createDesignFiles :: + FlatFuncMap + -> [(AST.VHDLId, AST.DesignFile)] + +createDesignFiles flatfuncmap = + -- TODO: Output types + map (Arrow.second $ AST.DesignFile context) units where - units = filter (not.null) $ map getLibraryUnits funcs + init_session = VHDLSession Map.empty Map.empty + (units, final_session) = + State.runState (createLibraryUnits flatfuncmap) init_session context = [ AST.Library $ mkVHDLId "IEEE", AST.Use $ (AST.NSimple $ mkVHDLId "IEEE.std_logic_1164") AST.:.: AST.All] - + +createLibraryUnits :: + FlatFuncMap + -> VHDLState [(AST.VHDLId, [AST.LibraryUnit])] + +createLibraryUnits flatfuncmap = do + let hsfuncs = Map.keys flatfuncmap + let flatfuncs = Map.elems flatfuncmap + entities <- Monad.zipWithM createEntity hsfuncs flatfuncs + archs <- Monad.zipWithM createArchitecture hsfuncs flatfuncs + return $ zipWith + (\ent arch -> + let AST.EntityDec id _ = ent in + (id, [AST.LUEntity ent, AST.LUArch arch]) + ) + entities archs + -- | Create an entity for a given function createEntity :: - HsFunction -- | The function signature - -> FuncData -- | The function data collected so far - -> Maybe Entity -- | The resulting entity. Should return the existing - --- Entity for builtin functions. - -createEntity hsfunc fdata = - case fdata ^. fdFlatFunc of - -- Skip (builtin) functions without a FlatFunction - Nothing -> fdata ^. fdEntity - -- Create an entity for all other functions - Just flatfunc -> + HsFunction -- | The function signature + -> FlatFunction -- | The FlatFunction + -> VHDLState AST.EntityDec -- | The resulting entity + +createEntity hsfunc flatfunc = let sigs = flat_sigs flatfunc args = flat_args flatfunc @@ -61,9 +78,12 @@ createEntity hsfunc fdata = pkg_decl = if null ty_decls && null ty_decls' then Nothing else Just $ AST.PackageDec pkg_id (map AST.PDITD $ ty_decls ++ ty_decls') + -- TODO: Output package AST.EntityDec entity_id _ = ent_decl' - in - Just $ Entity entity_id args' res' (Just ent_decl') pkg_decl + signature = Entity entity_id args' res' + in do + modA vsSignatures (Map.insert hsfunc signature) + return ent_decl' where mkMap :: [(SignalId, SignalInfo)] @@ -125,36 +145,30 @@ mkEntityId hsfunc = -- | Create an architecture for a given function createArchitecture :: - FuncMap -- ^ The functions in the current session - -> HsFunction -- ^ The function signature - -> FuncData -- ^ The function data collected so far - -> Maybe AST.ArchBody -- ^ The architecture for this function - -createArchitecture funcs hsfunc fdata = - case fdata ^. fdFlatFunc of - -- Skip (builtin) functions without a FlatFunction - Nothing -> fdata ^. fdArch - -- Create an architecture for all other functions - Just flatfunc -> - let - sigs = flat_sigs flatfunc - args = flat_args flatfunc - res = flat_res flatfunc - defs = flat_defs flatfunc - entity_id = Maybe.fromMaybe - (error $ "Building architecture without an entity? This should not happen!") - (getEntityId fdata) - -- Create signal declarations for all signals that are not in args and - -- res - (ty_decls, sig_decs) = Arrow.second Maybe.catMaybes $ Traversable.traverse (mkSigDec . snd) sigs - -- TODO: Unique ty_decls - -- TODO: Store ty_decls somewhere - -- Create concurrent statements for all signal definitions - statements = zipWith (mkConcSm funcs sigs) defs [0..] - procs = map mkStateProcSm (makeStatePairs flatfunc) - procs' = map AST.CSPSm procs - in - Just $ AST.ArchBody (mkVHDLId "structural") (AST.NSimple entity_id) (map AST.BDISD sig_decs) (statements ++ procs') + HsFunction -- ^ The function signature + -> FlatFunction -- ^ The FlatFunction + -> VHDLState AST.ArchBody -- ^ The architecture for this function + +createArchitecture hsfunc flatfunc = do + signaturemap <- getA vsSignatures + let signature = Maybe.fromMaybe + (error $ "Generating architecture for function " ++ (prettyShow hsfunc) ++ "without signature? This should not happen!") + (Map.lookup hsfunc signaturemap) + let entity_id = ent_id signature + -- Create concurrent statements for all signal definitions + let statements = zipWith (mkConcSm signaturemap sigs) defs [0..] + return $ AST.ArchBody (mkVHDLId "structural") (AST.NSimple entity_id) (map AST.BDISD sig_decs) (statements ++ procs') + where + sigs = flat_sigs flatfunc + args = flat_args flatfunc + res = flat_res flatfunc + defs = flat_defs flatfunc + -- Create signal declarations for all internal and state signals + (ty_decls, sig_decs) = Arrow.second Maybe.catMaybes $ Traversable.traverse (mkSigDec . snd) sigs + -- TODO: Unique ty_decls + -- TODO: Store ty_decls somewhere + procs = map mkStateProcSm (makeStatePairs flatfunc) + procs' = map AST.CSPSm procs -- | Looks up all pairs of old state, new state signals, together with -- the state id they represent. @@ -204,27 +218,23 @@ getSignalId info = -- | Transforms a signal definition into a VHDL concurrent statement mkConcSm :: - FuncMap -- ^ The functions in the current session + SignatureMap -- ^ The interfaces of functions in the session -> [(SignalId, SignalInfo)] -- ^ The signals in the current architecture -> SigDef -- ^ The signal definition -> Int -- ^ A number that will be unique for all -- concurrent statements in the architecture. -> AST.ConcSm -- ^ The corresponding VHDL component instantiation. -mkConcSm funcs sigs (FApp hsfunc args res) num = +mkConcSm signatures sigs (FApp hsfunc args res) num = let - fdata_maybe = Map.lookup hsfunc funcs - fdata = Maybe.fromMaybe - (error $ "Using function '" ++ (prettyShow hsfunc) ++ "' that is not in the session? This should not happen!") - fdata_maybe - entity = Maybe.fromMaybe - (error $ "Using function '" ++ (prettyShow hsfunc) ++ "' without entity declaration? This should not happen!") - (fdata ^. fdEntity) - entity_id = ent_id entity + signature = Maybe.fromMaybe + (error $ "Using function '" ++ (prettyShow hsfunc) ++ "' without signature? This should not happen!") + (Map.lookup hsfunc signatures) + entity_id = ent_id signature label = (AST.fromVHDLId entity_id) ++ "_" ++ (show num) -- Add a clk port if we have state clk_port = Maybe.fromJust $ mkAssocElem (Just $ mkVHDLId "clk") "clk" - portmaps = mkAssocElems sigs args res entity ++ (if hasState hsfunc then [clk_port] else []) + portmaps = mkAssocElems sigs args res signature ++ (if hasState hsfunc then [clk_port] else []) in AST.CSISm $ AST.CompInsSm (mkVHDLId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect portmaps) @@ -305,32 +315,6 @@ mkAssocElem :: Maybe AST.VHDLId -> String -> Maybe AST.AssocElem mkAssocElem (Just port) signal = Just $ Just port AST.:=>: (AST.ADName (AST.NSimple (mkVHDLId signal))) mkAssocElem Nothing _ = Nothing --- | Extracts the generated entity id from the given funcdata -getEntityId :: FuncData -> Maybe AST.VHDLId -getEntityId fdata = - case fdata ^. fdEntity of - Nothing -> Nothing - Just e -> case ent_decl e of - Nothing -> Nothing - Just (AST.EntityDec id _) -> Just id - -getLibraryUnits :: - FuncData -- | A function from the session - -> [AST.LibraryUnit] -- | The entity, architecture and optional package for the function - -getLibraryUnits fdata = - case fdata ^. fdEntity of - Nothing -> [] - Just ent -> - case ent_decl ent of - Nothing -> [] - Just decl -> - case fdata ^. fdArch of - Nothing -> [] - Just arch -> - [AST.LUEntity decl, AST.LUArch arch] - ++ (Maybe.maybeToList (fmap AST.LUPackageDec $ ent_pkg_decl ent)) - -- | The VHDL Bit type bit_ty :: AST.TypeMark bit_ty = AST.unsafeVHDLBasicId "Bit" diff --git a/VHDLTypes.hs b/VHDLTypes.hs index 7408486..948b3a1 100644 --- a/VHDLTypes.hs +++ b/VHDLTypes.hs @@ -1,10 +1,22 @@ -- -- Some types used by the VHDL module. -- +{-# LANGUAGE TemplateHaskell #-} module VHDLTypes where +-- Standard imports +import qualified Control.Monad.Trans.State as State +import qualified Data.Map as Map +import Data.Accessor +import qualified Data.Accessor.Template + +-- GHC API imports +import qualified Type + +-- ForSyDe imports import qualified ForSyDe.Backend.VHDL.AST as AST +-- Local imports import FlattenTypes import HsValueMap @@ -18,7 +30,34 @@ type VHDLSignalMap = HsValueMap (Maybe (AST.VHDLId, AST.TypeMark)) data Entity = Entity { ent_id :: AST.VHDLId, -- The id of the entity ent_args :: [VHDLSignalMap], -- A mapping of each function argument to port names - ent_res :: VHDLSignalMap, -- A mapping of the function result to port names - ent_decl :: Maybe AST.EntityDec, -- The actual entity declaration. Can be empty for builtin functions. - ent_pkg_decl :: Maybe AST.PackageDec -- A package declaration with types for this entity + ent_res :: VHDLSignalMap -- A mapping of the function result to port names } deriving (Show); + +-- A orderable equivalent of CoreSyn's Type for use as a map key +newtype OrdType = OrdType Type.Type +instance Eq OrdType where + (OrdType a) == (OrdType b) = Type.tcEqType a b +instance Ord OrdType where + compare (OrdType a) (OrdType b) = Type.tcCmpType a b + +-- A map of a Core type to the corresponding type name (and optionally, it's +-- declaration for non-primitive types). +type TypeMap = Map.Map OrdType (AST.VHDLId, AST.TypeDec) + +-- A map of a Haskell function to a hardware signature +type SignatureMap = Map.Map HsFunction Entity + +data VHDLSession = VHDLSession { + -- | A map of Core type -> VHDL Type + vsTypes_ :: TypeMap, + -- | A map of HsFunction -> hardware signature (entity name, port names, + -- etc.) + vsSignatures_ :: SignatureMap +} + +-- Derive accessors +$( Data.Accessor.Template.deriveAccessors ''VHDLSession ) + +type VHDLState = State.State VHDLSession + +-- vim: set ts=8 sw=2 sts=2 expandtab: