From: Matthijs Kooijman Date: Fri, 13 Feb 2009 13:45:05 +0000 (+0100) Subject: Generate a VHDL architecture for each function. X-Git-Url: https://git.stderr.nl/gitweb?a=commitdiff_plain;h=7a5b4eb318626f327dd6b0d69e99a8247f56399c;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git Generate a VHDL architecture for each function. The architecture contains signal declarations, but no instantiations yet. --- diff --git a/Pretty.hs b/Pretty.hs index 98a3d33..561cfb1 100644 --- a/Pretty.hs +++ b/Pretty.hs @@ -56,13 +56,16 @@ instance Pretty VHDLSession where $+$ text "NameCount: " $$ nest 15 (int nameCount) $+$ text "Functions: " $$ nest 15 (vcat (map ppfunc (Map.toList funcs))) where - ppfunc (hsfunc, (FuncData flatfunc entity)) = + ppfunc (hsfunc, (FuncData flatfunc entity arch)) = pPrint hsfunc $+$ (text "Flattened: " $$ nest 15 (ppffunc flatfunc)) $+$ (text "Entity") $$ nest 15 (ppent entity) + $+$ pparch arch ppffunc (Just f) = pPrint f ppffunc Nothing = text "Nothing" ppent (Just e) = pPrint e ppent Nothing = text "Nothing" + pparch Nothing = text "VHDL architecture not present" + pparch (Just _) = text "VHDL architecture present" modname = showSDoc $ Module.pprModule (HscTypes.cm_module mod) instance Pretty Entity where diff --git a/Translator.hs b/Translator.hs index 78c3a6f..7e66b18 100644 --- a/Translator.hs +++ b/Translator.hs @@ -70,6 +70,7 @@ main = mapM processBind binds modFuncs nameFlatFunction modFuncs VHDL.createEntity + modFuncs VHDL.createArchitecture -- Extract the library units generated from all the functions in the -- session. funcs <- getFuncs diff --git a/TranslatorTypes.hs b/TranslatorTypes.hs index 9978440..da1407a 100644 --- a/TranslatorTypes.hs +++ b/TranslatorTypes.hs @@ -9,6 +9,8 @@ import qualified Data.Map as Map import qualified HscTypes +import qualified ForSyDe.Backend.VHDL.AST as AST + import FlattenTypes import VHDLTypes import HsValueMap @@ -21,7 +23,8 @@ type FuncMap = Map.Map HsFunction FuncData -- | Some stuff we collect about a function along the way. data FuncData = FuncData { flatFunc :: Maybe FlatFunction, - entity :: Maybe Entity + entity :: Maybe Entity, + funcArch :: Maybe AST.ArchBody } data VHDLSession = VHDLSession { @@ -34,7 +37,7 @@ data VHDLSession = VHDLSession { addFunc :: HsFunction -> VHDLState () addFunc hsfunc = do fs <- State.gets funcs -- Get the funcs element from the session - let fs' = Map.insert hsfunc (FuncData Nothing Nothing) fs -- Insert function + let fs' = Map.insert hsfunc (FuncData Nothing Nothing Nothing) fs -- Insert function State.modify (\x -> x {funcs = fs' }) -- | Find the given function in the current session diff --git a/VHDL.hs b/VHDL.hs index 5516d00..9cea6fe 100644 --- a/VHDL.hs +++ b/VHDL.hs @@ -85,6 +85,49 @@ mkEntityId hsfunc = -- TODO: This doesn't work for functions with multiple signatures! mkVHDLId $ hsFuncName hsfunc +-- | Create an architecture for a given function +createArchitecture :: + HsFunction -- | The function signature + -> FuncData -- | The function data collected so far + -> FuncData -- | The modified function data + +createArchitecture hsfunc fdata = + let func = flatFunc fdata in + case func of + -- Skip (builtin) functions without a FlatFunction + Nothing -> fdata + -- Create an architecture for all other functions + Just flatfunc -> + let + s = sigs flatfunc + a = args flatfunc + r = res flatfunc + entity_id = Maybe.fromMaybe + (error $ "Building architecture without an entity? This should not happen!") + (getEntityId fdata) + sig_decs = [mkSigDec info | (id, info) <- s, (all (id `Foldable.notElem`) (r:a)) ] + arch = AST.ArchBody (mkVHDLId "structural") (AST.NSimple entity_id) (map AST.BDISD sig_decs) [] + in + fdata { funcArch = Just arch } + +mkSigDec :: SignalInfo -> AST.SigDec +mkSigDec info = + AST.SigDec (mkVHDLId name) (vhdl_ty ty) Nothing + where + name = Maybe.fromMaybe + (error $ "Unnamed signal? This should not happen!") + (sigName info) + ty = sigTy info + +-- | Extracts the generated entity id from the given funcdata +getEntityId :: FuncData -> Maybe AST.VHDLId +getEntityId fdata = + case entity fdata of + Nothing -> Nothing + Just e -> case ent_decl e of + Nothing -> Nothing + Just (AST.EntityDec id _) -> Just id + getLibraryUnits :: (HsFunction, FuncData) -- | A function from the session -> [AST.LibraryUnit] -- | The library units it generates @@ -95,6 +138,10 @@ getLibraryUnits (hsfunc, fdata) = Just ent -> case ent_decl ent of Nothing -> [] Just decl -> [AST.LUEntity decl] + ++ + case funcArch fdata of + Nothing -> [] + Just arch -> [AST.LUArch arch] -- | The VHDL Bit type bit_ty :: AST.TypeMark