From fcadaad2e47e5f6cba4b9f7d4341477b8fe74158 Mon Sep 17 00:00:00 2001 From: Matthijs Kooijman Date: Wed, 5 Aug 2009 12:12:28 +0200 Subject: [PATCH] Make vhdl generation and normalization lazy. Previously, first all function would be (recursively) normalized, and then VHDL would be generated. Now, functions are normalized when needed, and recursion is done while generating VHDL (so we know exactly which components we are instantiating). This disables the testbench and TFVec constructor for now, I'll fix that in the next commits. This also moves some code around, to prevent loops between Generate and VHDL (again...). The VHDLSession and NormalizeSession have been removed, and replaced with the (previously unused) TranslatorSession. There are a few backward compatibility aliases in place, so the next commit will probably remove these and do a bunch of trivial replaces all over the code. --- "c\316\273ash/CLasH/Normalize.hs" | 108 ++----- .../CLasH/Normalize/NormalizeTools.hs" | 9 +- .../CLasH/Normalize/NormalizeTypes.hs" | 14 +- "c\316\273ash/CLasH/Translator.hs" | 51 +-- .../CLasH/Translator/TranslatorTypes.hs" | 84 ++++- "c\316\273ash/CLasH/Utils.hs" | 24 +- "c\316\273ash/CLasH/Utils/Pretty.hs" | 11 +- "c\316\273ash/CLasH/VHDL.hs" | 262 ++++----------- "c\316\273ash/CLasH/VHDL/Generate.hs" | 297 ++++++++++++++---- "c\316\273ash/CLasH/VHDL/VHDLTools.hs" | 1 + "c\316\273ash/CLasH/VHDL/VHDLTypes.hs" | 73 +---- 11 files changed, 476 insertions(+), 458 deletions(-) diff --git "a/c\316\273ash/CLasH/Normalize.hs" "b/c\316\273ash/CLasH/Normalize.hs" index 8ec195b..7571a6f 100644 --- "a/c\316\273ash/CLasH/Normalize.hs" +++ "b/c\316\273ash/CLasH/Normalize.hs" @@ -4,7 +4,7 @@ -- top level function "normalize", and defines the actual transformation passes that -- are performed. -- -module CLasH.Normalize (normalizeModule) where +module CLasH.Normalize (getNormalized) where -- Standard modules import Debug.Trace @@ -34,8 +34,10 @@ import Outputable ( showSDoc, ppr, nest ) -- Local imports import CLasH.Normalize.NormalizeTypes +import CLasH.Translator.TranslatorTypes import CLasH.Normalize.NormalizeTools import CLasH.VHDL.VHDLTypes +import qualified CLasH.Utils as Utils import CLasH.Utils.Core.CoreTools import CLasH.Utils.Pretty @@ -472,78 +474,36 @@ funextracttop = everywhere ("funextract", funextract) -- What transforms to run? transforms = [argproptop, funextracttop, etatop, betatop, castproptop, letremovetop, letrectop, letsimpltop, letflattop, scrutsimpltop, casesimpltop, caseremovetop, inlinenonreptop, appsimpltop] --- Turns the given bind into VHDL -normalizeModule :: - HscTypes.HscEnv - -> UniqSupply.UniqSupply -- ^ A UniqSupply we can use - -> [(CoreBndr, CoreExpr)] -- ^ All bindings we know (i.e., in the current module) - -> [CoreExpr] - -> [CoreBndr] -- ^ The bindings to generate VHDL for (i.e., the top level bindings) - -> [Bool] -- ^ For each of the bindings to generate VHDL for, if it is stateful - -> ([(CoreBndr, CoreExpr)], [(CoreBndr, CoreExpr)], TypeState) -- ^ The resulting VHDL +-- | Returns the normalized version of the given function. +getNormalized :: + CoreBndr -- ^ The function to get + -> TranslatorSession CoreExpr -- The normalized function body -normalizeModule env uniqsupply bindings testexprs generate_for statefuls = runTransformSession env uniqsupply $ do - testbinds <- mapM (\x -> do { v <- mkBinderFor' x "test" ; return (v,x) } ) testexprs - let testbinders = (map fst testbinds) - -- Put all the bindings in this module in the tsBindings map - putA tsBindings (Map.fromList (bindings ++ testbinds)) - -- (Recursively) normalize each of the requested bindings - mapM normalizeBind (generate_for ++ testbinders) - -- Get all initial bindings and the ones we produced - bindings_map <- getA tsBindings - let bindings = Map.assocs bindings_map - normalized_binders' <- getA tsNormalized - let normalized_binders = VarSet.delVarSetList normalized_binders' testbinders - let ret_testbinds = zip testbinders (Maybe.catMaybes $ map (\x -> lookup x bindings) testbinders) - let ret_binds = filter ((`VarSet.elemVarSet` normalized_binders) . fst) bindings - typestate <- getA tsType - -- But return only the normalized bindings - return $ (ret_binds, ret_testbinds, typestate) +getNormalized bndr = Utils.makeCached bndr tsNormalized $ do + if is_poly (Var bndr) + then + -- This should really only happen at the top level... TODO: Give + -- a different error if this happens down in the recursion. + error $ "\nNormalize.normalizeBind: Function " ++ show bndr ++ " is polymorphic, can't normalize" + else do + expr <- getBinding bndr + -- Introduce an empty Let at the top level, so there will always be + -- a let in the expression (none of the transformations will remove + -- the last let). + let expr' = Let (Rec []) expr + -- Normalize this expression + trace ("Transforming " ++ (show bndr) ++ "\nBefore:\n\n" ++ showSDoc ( ppr expr' ) ++ "\n") $ return () + expr'' <- dotransforms transforms expr' + trace ("\nAfter:\n\n" ++ showSDoc ( ppr expr')) $ return () + return expr'' -normalizeBind :: CoreBndr -> TransformSession () -normalizeBind bndr = - -- Don't normalize global variables, these should be either builtin - -- functions or data constructors. - Monad.when (Var.isLocalId bndr) $ do - -- Skip binders that have a polymorphic type, since it's impossible to - -- create polymorphic hardware. - if is_poly (Var bndr) - then - -- This should really only happen at the top level... TODO: Give - -- a different error if this happens down in the recursion. - error $ "\nNormalize.normalizeBind: Function " ++ show bndr ++ " is polymorphic, can't normalize" - else do - normalized_funcs <- getA tsNormalized - -- See if this function was normalized already - if VarSet.elemVarSet bndr normalized_funcs - then - -- Yup, don't do it again - return () - else do - -- Nope, note that it has been and do it. - modA tsNormalized (flip VarSet.extendVarSet bndr) - expr_maybe <- getGlobalBind bndr - case expr_maybe of - Just expr -> do - -- Introduce an empty Let at the top level, so there will always be - -- a let in the expression (none of the transformations will remove - -- the last let). - let expr' = Let (Rec []) expr - -- Normalize this expression - trace ("Transforming " ++ (show bndr) ++ "\nBefore:\n\n" ++ showSDoc ( ppr expr' ) ++ "\n") $ return () - expr' <- dotransforms transforms expr' - trace ("\nAfter:\n\n" ++ showSDoc ( ppr expr')) $ return () - -- And store the normalized version in the session - modA tsBindings (Map.insert bndr expr') - -- Find all vars used with a function type. All of these should be global - -- binders (i.e., functions used), since any local binders with a function - -- type should have been inlined already. - bndrs <- getGlobalBinders - let used_funcs_set = CoreFVs.exprSomeFreeVars (\v -> not (Id.isDictId v) && v `elem` bndrs) expr' - let used_funcs = VarSet.varSetElems used_funcs_set - -- Process each of the used functions recursively - mapM normalizeBind used_funcs - return () - -- We don't have a value for this binder. This really shouldn't - -- happen for local id's... - Nothing -> error $ "\nNormalize.normalizeBind: No value found for binder " ++ pprString bndr ++ "? This should not happen!" +-- | Get the value that is bound to the given binder at top level. Fails when +-- there is no such binding. +getBinding :: + CoreBndr -- ^ The binder to get the expression for + -> TranslatorSession CoreExpr -- ^ The value bound to the binder + +getBinding bndr = Utils.makeCached bndr tsBindings $ do + -- If the binding isn't in the "cache" (bindings map), then we can't create + -- it out of thin air, so return an error. + error $ "Normalize.getBinding: Unknown function requested: " ++ show bndr diff --git "a/c\316\273ash/CLasH/Normalize/NormalizeTools.hs" "b/c\316\273ash/CLasH/Normalize/NormalizeTools.hs" index 7f575ad..0ae958a 100644 --- "a/c\316\273ash/CLasH/Normalize/NormalizeTools.hs" +++ "b/c\316\273ash/CLasH/Normalize/NormalizeTools.hs" @@ -35,6 +35,7 @@ import Outputable ( showSDoc, ppr, nest ) -- Local imports import CLasH.Normalize.NormalizeTypes +import CLasH.Translator.TranslatorTypes import CLasH.Utils.Pretty import CLasH.VHDL.VHDLTypes import qualified CLasH.VHDL.VHDLTools as VHDLTools @@ -258,14 +259,6 @@ substitute ((b, e):subss) expr = substitute subss' expr' -- substitutions subss' = map (Arrow.second (CoreSubst.substExpr subs)) subss --- Run a given TransformSession. Used mostly to setup the right calls and --- an initial state. -runTransformSession :: HscTypes.HscEnv -> UniqSupply.UniqSupply -> TransformSession a -> a -runTransformSession env uniqSupply session = State.evalState session emptyTransformState - where - emptyTypeState = TypeState Map.empty [] Map.empty Map.empty env - emptyTransformState = TransformState uniqSupply Map.empty VarSet.emptyVarSet emptyTypeState - -- Is the given expression representable at runtime, based on the type? isRepr :: CoreSyn.CoreExpr -> TransformMonad Bool isRepr (Type ty) = return False diff --git "a/c\316\273ash/CLasH/Normalize/NormalizeTypes.hs" "b/c\316\273ash/CLasH/Normalize/NormalizeTypes.hs" index 90589f8..2383cdf 100644 --- "a/c\316\273ash/CLasH/Normalize/NormalizeTypes.hs" +++ "b/c\316\273ash/CLasH/Normalize/NormalizeTypes.hs" @@ -13,26 +13,14 @@ import Debug.Trace -- GHC API import CoreSyn -import qualified UniqSupply import qualified VarSet import Outputable ( Outputable, showSDoc, ppr ) -- Local imports import CLasH.Utils.Core.CoreShow import CLasH.Utils.Pretty -import CLasH.VHDL.VHDLTypes -- For TypeState +import CLasH.Translator.TranslatorTypes -data TransformState = TransformState { - tsUniqSupply_ :: UniqSupply.UniqSupply - , tsBindings_ :: Map.Map CoreBndr CoreExpr - , tsNormalized_ :: VarSet.VarSet -- ^ The binders that have been normalized - , tsType_ :: TypeState -} - -$( Data.Accessor.Template.deriveAccessors ''TransformState ) - --- A session of multiple transformations over multiple expressions -type TransformSession = (State.State TransformState) -- Wrap a writer around a TransformSession, to run a single transformation -- over a single expression and track if the expression was changed. type TransformMonad = Writer.WriterT Monoid.Any TransformSession diff --git "a/c\316\273ash/CLasH/Translator.hs" "b/c\316\273ash/CLasH/Translator.hs" index 445dd9c..20dab4f 100644 --- "a/c\316\273ash/CLasH/Translator.hs" +++ "b/c\316\273ash/CLasH/Translator.hs" @@ -8,7 +8,10 @@ import qualified System.Directory as Directory import qualified Maybe import qualified Monad import qualified System.FilePath as FilePath +import qualified Control.Monad.Trans.State as State import Text.PrettyPrint.HughesPJ (render) +import Data.Accessor +import qualified Data.Map as Map -- GHC API import qualified CoreSyn @@ -23,6 +26,7 @@ import qualified Language.VHDL.Ppr as Ppr -- Local Imports import CLasH.Normalize +import CLasH.Translator.TranslatorTypes import CLasH.Translator.Annotations import CLasH.Utils.Core.CoreTools import CLasH.Utils.GhcTools @@ -92,27 +96,32 @@ moduleToVHDL :: -> [Maybe CoreSyn.CoreExpr] -- ^ The TestInput -> Bool -- ^ Is it stateful (in case InitState is not specified) -> IO [(AST.VHDLId, AST.DesignFile)] -moduleToVHDL env cores top init test stateful = do - let topEntity = Maybe.catMaybes top - case topEntity of - [] -> error "Top Entity Not Found" - [topEnt] -> do - let initialState = Maybe.catMaybes init - let isStateful = not (null initialState) || stateful - let testInput = Maybe.catMaybes test - -- Generate a UniqSupply - -- Running - -- egrep -r "(initTcRnIf|mkSplitUniqSupply)" . - -- on the compiler dir of ghc suggests that 'z' is not used to generate - -- a unique supply anywhere. - uniqSupply <- UniqSupply.mkSplitUniqSupply 'z' - let all_bindings = concat (map (\x -> CoreSyn.flattenBinds (HscTypes.cm_binds x)) cores) - let testexprs = case testInput of [] -> [] ; [x] -> reduceCoreListToHsList x - let (normalized_bindings, test_bindings, typestate) = normalizeModule env uniqSupply all_bindings testexprs [topEnt] [isStateful] - let vhdl = createDesignFiles typestate normalized_bindings topEnt test_bindings - mapM (putStr . render . Ppr.ppr . snd) vhdl - return vhdl - xs -> error "More than one topentity found" +moduleToVHDL env cores topbinds' init test stateful = do + let topbinds = Maybe.catMaybes topbinds' + let initialState = Maybe.catMaybes init + let testInput = Maybe.catMaybes test + vhdl <- runTranslatorSession env $ do + let all_bindings = concat (map (\x -> CoreSyn.flattenBinds (HscTypes.cm_binds x)) cores) + -- Store the bindings we loaded + tsBindings %= Map.fromList all_bindings + --let testexprs = case testInput of [] -> [] ; [x] -> reduceCoreListToHsList x + createDesignFiles topbinds + mapM (putStr . render . Ppr.ppr . snd) vhdl + return vhdl + +-- Run the given translator session. Generates a new UniqSupply for that +-- session. +runTranslatorSession :: HscTypes.HscEnv -> TranslatorSession a -> IO a +runTranslatorSession env session = do + -- Generate a UniqSupply + -- Running + -- egrep -r "(initTcRnIf|mkSplitUniqSupply)" . + -- on the compiler dir of ghc suggests that 'z' is not used to generate + -- a unique supply anywhere. + uniqSupply <- UniqSupply.mkSplitUniqSupply 'z' + let init_typestate = TypeState Map.empty [] Map.empty Map.empty env + let init_state = TranslatorState uniqSupply init_typestate Map.empty Map.empty Map.empty Map.empty + return $ State.evalState session init_state -- | Prepares the directory for writing VHDL files. This means creating the -- dir if it does not exist and removing all existing .vhdl files from it. diff --git "a/c\316\273ash/CLasH/Translator/TranslatorTypes.hs" "b/c\316\273ash/CLasH/Translator/TranslatorTypes.hs" index 0ab3b87..5fb97c2 100644 --- "a/c\316\273ash/CLasH/Translator/TranslatorTypes.hs" +++ "b/c\316\273ash/CLasH/Translator/TranslatorTypes.hs" @@ -5,25 +5,99 @@ {-# LANGUAGE TemplateHaskell #-} module CLasH.Translator.TranslatorTypes where +-- Standard modules import qualified Control.Monad.Trans.State as State import qualified Data.Map as Map import qualified Data.Accessor.Template import Data.Accessor +-- GHC API +import qualified CoreSyn +import qualified Type import qualified HscTypes +import qualified UniqSupply +-- ForSyDe import qualified Language.VHDL.AST as AST +-- Local imports import CLasH.VHDL.VHDLTypes -data TranslatorSession = TranslatorSession { - tsCoreModule_ :: HscTypes.CoreModule, -- ^ The current module - tsNameCount_ :: Int -- ^ A counter that can be used to generate unique names +-- A orderable equivalent of CoreSyn's Type for use as a map key +newtype OrdType = OrdType { getType :: 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 + +data HType = StdType OrdType | + ADTType String [HType] | + VecType Int HType | + SizedWType Int | + RangedWType Int | + SizedIType Int | + BuiltinType String + deriving (Eq, Ord) + +-- A map of a Core type to the corresponding type name +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. +type TypeFunMap = Map.Map (OrdType, String) (AST.VHDLId, AST.SubProgBody) + +type TfpIntMap = Map.Map OrdType Int +-- A substate that deals with type generation +data TypeState = TypeState { + -- | A map of Core type -> VHDL Type + tsTypes_ :: TypeMap, + -- | A list of type declarations + tsTypeDecls_ :: [AST.PackageDecItem], + -- | A map of vector Core type -> VHDL type function + tsTypeFuns_ :: TypeFunMap, + tsTfpInts_ :: TfpIntMap, + tsHscEnv_ :: HscTypes.HscEnv +} + +-- Derive accessors +$( Data.Accessor.Template.deriveAccessors ''TypeState ) + +-- Compatibility with old VHDLSession +vsTypes = tsTypes +vsTypeDecls = tsTypeDecls +vsTypeFuns = tsTypeFuns +vsTfpInts = tsTfpInts +vsHscEnv = tsHscEnv + +-- Define a session +type TypeSession = State.State TypeState +-- A global state for the translator +data TranslatorState = TranslatorState { + tsUniqSupply_ :: UniqSupply.UniqSupply + , tsType_ :: TypeState + , tsBindings_ :: Map.Map CoreSyn.CoreBndr CoreSyn.CoreExpr + , tsNormalized_ :: Map.Map CoreSyn.CoreBndr CoreSyn.CoreExpr + , tsEntities_ :: Map.Map CoreSyn.CoreBndr Entity + , tsArchitectures_ :: Map.Map CoreSyn.CoreBndr (Architecture, [CoreSyn.CoreBndr]) } -- Derive accessors -$( Data.Accessor.Template.deriveAccessors ''TranslatorSession ) +$( Data.Accessor.Template.deriveAccessors ''TranslatorState ) + +type TranslatorSession = State.State TranslatorState + +-- Compatibility for the old VHDLSesssion +vsType = tsType +type VHDLSession = TranslatorSession + +-- Compatibility for the old TransformSession +type TransformSession = TranslatorSession -type TranslatorState = State.State TranslatorSession +-- Does the given binder reference a top level binder in the current +-- module(s)? +isTopLevelBinder :: CoreSyn.CoreBndr -> TranslatorSession Bool +isTopLevelBinder bndr = do + bindings <- getA tsBindings + return $ Map.member bndr bindings -- vim: set ts=8 sw=2 sts=2 expandtab: diff --git "a/c\316\273ash/CLasH/Utils.hs" "b/c\316\273ash/CLasH/Utils.hs" index c539c79..705a466 100644 --- "a/c\316\273ash/CLasH/Utils.hs" +++ "b/c\316\273ash/CLasH/Utils.hs" @@ -1,10 +1,14 @@ module CLasH.Utils ( listBindings , listBind + , makeCached ) where -- Standard Imports import qualified Maybe +import Data.Accessor +import qualified Data.Map as Map +import qualified Control.Monad.Trans.State as State -- GHC API import qualified CoreSyn @@ -46,4 +50,22 @@ listBind libdir filenames name = do listBinding (Maybe.fromJust $ head corebind, Maybe.fromJust $ head coreexpr) where bindFinder = findBind (hasVarName name) - exprFinder = findExpr (hasVarName name) \ No newline at end of file + exprFinder = findExpr (hasVarName name) + +-- Make a caching version of a stateful computatation. +makeCached :: (Monad m, Ord k) => + k -- ^ The key to use for the cache + -> Accessor s (Map.Map k v) -- ^ The accessor to get at the cache + -> State.StateT s m v -- ^ How to compute the value to cache? + -> State.StateT s m v -- ^ The resulting value, from the cache or freshly + -- computed. +makeCached key accessor create = do + cache <- getA accessor + case Map.lookup key cache of + -- Found in cache, just return + Just value -> return value + -- Not found, compute it and put it in the cache + Nothing -> do + value <- create + modA accessor (Map.insert key value) + return value diff --git "a/c\316\273ash/CLasH/Utils/Pretty.hs" "b/c\316\273ash/CLasH/Utils/Pretty.hs" index 4366b10..56b3aaf 100644 --- "a/c\316\273ash/CLasH/Utils/Pretty.hs" +++ "b/c\316\273ash/CLasH/Utils/Pretty.hs" @@ -24,14 +24,6 @@ import CLasH.Utils.Core.CoreShow printList :: (a -> Doc) -> [a] -> Doc printList f = brackets . fsep . punctuate comma . map f -instance Pretty TranslatorSession where - pPrint (TranslatorSession mod nameCount) = - text "Module: " $$ nest 15 (text modname) - $+$ text "NameCount: " $$ nest 15 (int nameCount) - where - 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) = @@ -48,10 +40,11 @@ instance Pretty FuncData where -} instance Pretty Entity where - pPrint (Entity id args res) = + pPrint (Entity id args res decl) = text "Entity: " $$ nest 10 (pPrint id) $+$ text "Args: " $$ nest 10 (pPrint args) $+$ text "Result: " $$ nest 10 (pPrint res) + $+$ text "Declaration not shown" instance (OutputableBndr b, Show b) => Pretty (CoreSyn.Bind b) where pPrint (CoreSyn.NonRec b expr) = diff --git "a/c\316\273ash/CLasH/VHDL.hs" "b/c\316\273ash/CLasH/VHDL.hs" index fd83899..944d33f 100644 --- "a/c\316\273ash/CLasH/VHDL.hs" +++ "b/c\316\273ash/CLasH/VHDL.hs" @@ -4,7 +4,6 @@ module CLasH.VHDL where -- Standard modules -import qualified Data.List as List import qualified Data.Map as Map import qualified Maybe import qualified Control.Monad as Monad @@ -23,7 +22,6 @@ import CoreSyn --import qualified Type import qualified Name import qualified Var -import qualified Id import qualified IdInfo import qualified TyCon import qualified DataCon @@ -32,6 +30,7 @@ import qualified CoreUtils import Outputable ( showSDoc, ppr ) -- Local imports +import CLasH.Translator.TranslatorTypes import CLasH.VHDL.VHDLTypes import CLasH.VHDL.VHDLTools import CLasH.Utils.Pretty @@ -41,41 +40,59 @@ import CLasH.VHDL.Generate -- import CLasH.VHDL.Testbench createDesignFiles :: - TypeState - -> [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)] - -> CoreSyn.CoreBndr -- ^ Top binder - -> [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)] -- ^ Test Input - -> [(AST.VHDLId, AST.DesignFile)] - -createDesignFiles init_typestate binds topbind testinput = - (mkVHDLBasicId "types", AST.DesignFile ieee_context [type_package_dec, type_package_body]) : - map (Arrow.second $ AST.DesignFile full_context) (units ++ [testbench]) - + [CoreSyn.CoreBndr] -- ^ Top binders + -> TranslatorSession [(AST.VHDLId, AST.DesignFile)] + +createDesignFiles topbndrs = do + bndrss <- mapM recurseArchitectures topbndrs + let bndrs = concat bndrss + lunits <- mapM createLibraryUnit bndrs + typepackage <- createTypesPackage + let files = map (Arrow.second $ AST.DesignFile full_context) lunits + return $ typepackage : files where - init_session = VHDLState init_typestate Map.empty - (units, final_session') = - State.runState (createLibraryUnits binds) init_session - (testbench, final_session) = - State.runState (createTestBench Nothing testinput topbind) final_session' - tyfun_decls = mkBuiltInShow ++ (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) (AST.NSimple $ highId) Nothing) - tfvec_index_def = AST.SubtypeIn integerTM (Just tfvec_range) - ieee_context = [ - AST.Library $ mkVHDLBasicId "IEEE", - mkUseAll ["IEEE", "std_logic_1164"], - mkUseAll ["IEEE", "numeric_std"], - mkUseAll ["std", "textio"] - ] full_context = mkUseAll ["work", "types"] : (mkUseAll ["work"] : ieee_context) - type_package_dec = AST.LUPackageDec $ AST.PackageDec (mkVHDLBasicId "types") ([tfvec_index_decl] ++ ty_decls ++ subProgSpecs) - type_package_body = AST.LUPackageBody $ AST.PackageBody typesId tyfun_decls - subProgSpecs = map subProgSpec tyfun_decls - subProgSpec = \(AST.SubProgBody spec _ _) -> AST.PDISS spec + +ieee_context = [ + AST.Library $ mkVHDLBasicId "IEEE", + mkUseAll ["IEEE", "std_logic_1164"], + mkUseAll ["IEEE", "numeric_std"], + mkUseAll ["std", "textio"] + ] + +-- | Find out which entities are needed for the given top level binders. +recurseArchitectures :: + CoreSyn.CoreBndr -- ^ The top level binder + -> TranslatorSession [CoreSyn.CoreBndr] + -- ^ The binders of all needed functions. +recurseArchitectures bndr = do + -- See what this binder directly uses + (_, used) <- getArchitecture bndr + -- Recursively check what each of the used functions uses + useds <- mapM recurseArchitectures used + -- And return all of them + return $ bndr : (concat useds) + +-- | Creates the types package, based on the current type state. +createTypesPackage :: + TranslatorSession (AST.VHDLId, AST.DesignFile) + -- ^ The id and content of the types package + +createTypesPackage = do + tyfuns <- getA (tsType .> tsTypeFuns) + let tyfun_decls = mkBuiltInShow ++ (map snd $ Map.elems tyfuns) + ty_decls <- getA (tsType .> tsTypeDecls) + let subProgSpecs = map (\(AST.SubProgBody spec _ _) -> AST.PDISS spec) tyfun_decls + let type_package_dec = AST.LUPackageDec $ AST.PackageDec (mkVHDLBasicId "types") ([tfvec_index_decl] ++ ty_decls ++ subProgSpecs) + let type_package_body = AST.LUPackageBody $ AST.PackageBody typesId tyfun_decls + return $ (mkVHDLBasicId "types", AST.DesignFile ieee_context [type_package_dec, type_package_body]) + where + 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) (AST.NSimple $ highId) Nothing) + tfvec_index_def = AST.SubtypeIn integerTM (Just tfvec_range) -- Create a use foo.bar.all statement. Takes a list of components in the used -- name. Must contain at least two components @@ -87,122 +104,14 @@ mkUseAll ss = from = foldl select base_prefix (tail ss) select prefix s = AST.NSelected $ prefix AST.:.: (AST.SSimple $ mkVHDLBasicId s) -createLibraryUnits :: - [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)] - -> VHDLSession [(AST.VHDLId, [AST.LibraryUnit])] - -createLibraryUnits binds = do - entities <- Monad.mapM createEntity binds - archs <- Monad.mapM createArchitecture binds - return $ zipWith - (\ent arch -> - let AST.EntityDec id _ = ent in - (id, [AST.LUEntity ent, AST.LUArch arch]) - ) - entities archs +createLibraryUnit :: + CoreSyn.CoreBndr + -> TranslatorSession (AST.VHDLId, [AST.LibraryUnit]) --- | Create an entity for a given function -createEntity :: - (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The function - -> VHDLSession AST.EntityDec -- ^ The resulting entity - -createEntity (fname, expr) = do - -- Strip off lambda's, these will be arguments - let (args, letexpr) = CoreSyn.collectBinders expr - args' <- Monad.mapM mkMap args - -- There must be a let at top level - let (CoreSyn.Let binds (CoreSyn.Var res)) = letexpr - res' <- mkMap res - let vhdl_id = mkVHDLBasicId $ varToString fname ++ "_" ++ varToStringUniq fname - let ent_decl' = createEntityAST vhdl_id args' res' - let AST.EntityDec entity_id _ = ent_decl' - let signature = Entity entity_id args' res' - modA vsSignatures (Map.insert fname signature) - return ent_decl' - where - mkMap :: - --[(SignalId, SignalInfo)] - CoreSyn.CoreBndr - -> VHDLSession Port - -- We only need the vsTypes element from the state - mkMap = (\bndr -> - let - --info = Maybe.fromMaybe - -- (error $ "Signal not found in the name map? This should not happen!") - -- (lookup id sigmap) - -- Assume the bndr has a valid VHDL id already - id = varToVHDLId bndr - 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 <- MonadState.lift vsType $ vhdl_ty error_msg ty - return (id, type_mark) - ) - --- | Create the VHDL AST for an entity -createEntityAST :: - AST.VHDLId -- ^ The name of the function - -> [Port] -- ^ The entity's arguments - -> Port -- ^ The entity's result - -> AST.EntityDec -- ^ The entity with the ent_decl filled in as well - -createEntityAST vhdl_id args res = - AST.EntityDec vhdl_id ports - where - -- Create a basic Id, since VHDL doesn't grok filenames with extended Ids. - ports = map (mkIfaceSigDec AST.In) args - ++ [mkIfaceSigDec AST.Out res] - ++ [clk_port] - -- Add a clk port if we have state - clk_port = AST.IfaceSigDec clockId AST.In std_logicTM - --- | Create a port declaration -mkIfaceSigDec :: - AST.Mode -- ^ The mode for the port (In / Out) - -> (AST.VHDLId, AST.TypeMark) -- ^ The id and type for the port - -> AST.IfaceSigDec -- ^ The resulting port declaration - -mkIfaceSigDec mode (id, ty) = AST.IfaceSigDec id mode ty - -{- --- | Generate a VHDL entity name for the given hsfunc -mkEntityId hsfunc = - -- TODO: This doesn't work for functions with multiple signatures! - -- Use a Basic Id, since using extended id's for entities throws off - -- precision and causes problems when generating filenames. - mkVHDLBasicId $ hsFuncName hsfunc --} - --- | Create an architecture for a given function -createArchitecture :: - (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The function - -> VHDLSession AST.ArchBody -- ^ The architecture for this function - -createArchitecture (fname, expr) = do - signaturemap <- getA vsSignatures - let signature = Maybe.fromMaybe - (error $ "\nVHDL.createArchitecture: Generating architecture for function \n" ++ (pprString fname) ++ "\nwithout signature? This should not happen!") - (Map.lookup fname signaturemap) - let entity_id = ent_id signature - -- Strip off lambda's, these will be arguments - let (args, letexpr) = CoreSyn.collectBinders expr - -- There must be a let at top level - let (CoreSyn.Let (CoreSyn.Rec binds) (Var res)) = letexpr - - -- Create signal declarations for all binders in the let expression, except - -- for the output port (that will already have an output port declared in - -- the entity). - sig_dec_maybes <- mapM (mkSigDec' . fst) (filter ((/=res).fst) binds) - let sig_decs = Maybe.catMaybes $ sig_dec_maybes - - statementss <- Monad.mapM mkConcSm binds - let statements = concat statementss - return $ AST.ArchBody (mkVHDLBasicId "structural") (AST.NSimple entity_id) (map AST.BDISD sig_decs) (statements ++ procs') - where - procs = [] --map mkStateProcSm [] -- (makeStatePairs flatfunc) - procs' = map AST.CSPSm procs - -- mkSigDec only uses vsTypes from the state - mkSigDec' = mkSigDec +createLibraryUnit bndr = do + entity <- getEntity bndr + (arch, _) <- getArchitecture bndr + return (ent_id entity, [AST.LUEntity (ent_dec entity), AST.LUArch arch]) {- -- | Looks up all pairs of old state, new state signals, together with @@ -241,60 +150,7 @@ getSignalId info = (sigName info) -} --- | Transforms a core binding into a VHDL concurrent statement -mkConcSm :: - (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The binding to process - -> VHDLSession [AST.ConcSm] -- ^ The corresponding VHDL component instantiations. - - --- Ignore Cast expressions, they should not longer have any meaning as long as --- the type works out. -mkConcSm (bndr, Cast expr ty) = mkConcSm (bndr, expr) - --- Simple a = b assignments are just like applications, but without arguments. --- We can't just generate an unconditional assignment here, since b might be a --- top level binding (e.g., a function with no arguments). -mkConcSm (bndr, Var v) = do - genApplication (Left bndr) v [] - -mkConcSm (bndr, app@(CoreSyn.App _ _))= do - let (CoreSyn.Var f, args) = CoreSyn.collectArgs app - let valargs = get_val_args (Var.varType f) args - genApplication (Left bndr) f (map Left valargs) - --- A single alt case must be a selector. This means thee scrutinee is a simple --- variable, the alternative is a dataalt with a single non-wild binder that --- is also returned. -mkConcSm (bndr, expr@(Case (Var scrut) b ty [alt])) = - case alt of - (DataAlt dc, bndrs, (Var sel_bndr)) -> do - case List.elemIndex sel_bndr bndrs of - Just i -> do - 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 - return [mkUncondAssign (Left bndr) sel_expr] - Nothing -> error $ "\nVHDL.mkConcSM: Not in normal form: Not a selector case:\n" ++ (pprString expr) - - _ -> error $ "\nVHDL.mkConcSM: Not in normal form: Not a selector case:\n" ++ (pprString expr) - --- Multiple case alt are be conditional assignments and have only wild --- binders in the alts and only variables in the case values and a variable --- for a scrutinee. We check the constructor of the second alt, since the --- first is the default case, if there is any. -mkConcSm (bndr, (Case (Var scrut) b ty [(_, _, Var false), (con, _, Var true)])) = do - scrut' <- MonadState.lift vsType $ varToVHDLExpr scrut - let cond_expr = scrut' AST.:=: (altconToVHDLExpr con) - true_expr <- MonadState.lift vsType $ varToVHDLExpr true - false_expr <- MonadState.lift vsType $ varToVHDLExpr false - return [mkCondAssign (Left bndr) cond_expr true_expr false_expr] - -mkConcSm (_, (Case (Var _) _ _ alts)) = error "\nVHDL.mkConcSm: Not in normal form: Case statement with more than two alternatives" -mkConcSm (_, Case _ _ _ _) = error "\nVHDL.mkConcSm: Not in normal form: Case statement has does not have a simple variable as scrutinee" -mkConcSm (bndr, expr) = error $ "\nVHDL.mkConcSM: Unsupported binding in let expression: " ++ pprString bndr ++ " = " ++ pprString expr - - +{- createTestBench :: Maybe Int -- ^ Number of cycles to simulate -> [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)] -- ^ Input stimuli @@ -382,7 +238,7 @@ createStimulans (bndr, expr) cycl = do let block_label = mkVHDLExtId ("testcycle_" ++ (show cycl)) let block = AST.BlockSm block_label [] (AST.PMapAspect []) sig_decs (concat stimulansbinds) return (AST.CSBSm block, res) - + -- | generates a clock process with a period of 10ns createClkProc :: AST.ProcSm createClkProc = AST.ProcSm (AST.unsafeVHDLBasicId "clkproc") [] sms @@ -411,3 +267,5 @@ createOutputProc outs = genExprPCall2 writeId (AST.PrimName $ AST.NSimple outputId) ((genExprFCall showId (AST.PrimName $ AST.NSimple outSig)) AST.:&: suffix) + +-} diff --git "a/c\316\273ash/CLasH/VHDL/Generate.hs" "b/c\316\273ash/CLasH/VHDL/Generate.hs" index 4483086..df64635 100644 --- "a/c\316\273ash/CLasH/VHDL/Generate.hs" +++ "b/c\316\273ash/CLasH/VHDL/Generate.hs" @@ -1,7 +1,9 @@ module CLasH.VHDL.Generate where -- Standard modules +import qualified Data.List as List import qualified Data.Map as Map +import qualified Control.Monad as Monad import qualified Maybe import qualified Data.Either as Either import Data.Accessor @@ -15,17 +17,175 @@ import qualified Language.VHDL.AST as AST import qualified CoreSyn import qualified Type import qualified Var +import qualified Id import qualified IdInfo import qualified Literal import qualified Name import qualified TyCon -- Local imports +import CLasH.Translator.TranslatorTypes import CLasH.VHDL.Constants import CLasH.VHDL.VHDLTypes import CLasH.VHDL.VHDLTools +import qualified CLasH.Utils as Utils import CLasH.Utils.Core.CoreTools import CLasH.Utils.Pretty +import qualified CLasH.Normalize as Normalize + +----------------------------------------------------------------------------- +-- Functions to generate VHDL for user-defined functions. +----------------------------------------------------------------------------- + +-- | Create an entity for a given function +getEntity :: + CoreSyn.CoreBndr + -> VHDLSession Entity -- ^ The resulting entity + +getEntity fname = Utils.makeCached fname tsEntities $ do + expr <- Normalize.getNormalized fname + -- Strip off lambda's, these will be arguments + let (args, letexpr) = CoreSyn.collectBinders expr + args' <- mapM mkMap args + -- There must be a let at top level + let (CoreSyn.Let binds (CoreSyn.Var res)) = letexpr + res' <- mkMap res + let vhdl_id = mkVHDLBasicId $ varToString fname ++ "_" ++ varToStringUniq fname + let ent_decl' = createEntityAST vhdl_id args' res' + let AST.EntityDec entity_id _ = ent_decl' + let signature = Entity entity_id args' res' ent_decl' + return signature + where + mkMap :: + --[(SignalId, SignalInfo)] + CoreSyn.CoreBndr + -> VHDLSession Port + -- We only need the vsTypes element from the state + mkMap = (\bndr -> + let + --info = Maybe.fromMaybe + -- (error $ "Signal not found in the name map? This should not happen!") + -- (lookup id sigmap) + -- Assume the bndr has a valid VHDL id already + id = varToVHDLId bndr + 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 <- MonadState.lift vsType $ vhdl_ty error_msg ty + return (id, type_mark) + ) + +-- | Create the VHDL AST for an entity +createEntityAST :: + AST.VHDLId -- ^ The name of the function + -> [Port] -- ^ The entity's arguments + -> Port -- ^ The entity's result + -> AST.EntityDec -- ^ The entity with the ent_decl filled in as well + +createEntityAST vhdl_id args res = + AST.EntityDec vhdl_id ports + where + -- Create a basic Id, since VHDL doesn't grok filenames with extended Ids. + ports = map (mkIfaceSigDec AST.In) args + ++ [mkIfaceSigDec AST.Out res] + ++ [clk_port] + -- Add a clk port if we have state + clk_port = AST.IfaceSigDec clockId AST.In std_logicTM + +-- | Create a port declaration +mkIfaceSigDec :: + AST.Mode -- ^ The mode for the port (In / Out) + -> (AST.VHDLId, AST.TypeMark) -- ^ The id and type for the port + -> AST.IfaceSigDec -- ^ The resulting port declaration + +mkIfaceSigDec mode (id, ty) = AST.IfaceSigDec id mode ty + +-- | Create an architecture for a given function +getArchitecture :: + CoreSyn.CoreBndr -- ^ The function to get an architecture for + -> VHDLSession (Architecture, [CoreSyn.CoreBndr]) + -- ^ The architecture for this function + +getArchitecture fname = Utils.makeCached fname tsArchitectures $ do + expr <- Normalize.getNormalized fname + signature <- getEntity fname + let entity_id = ent_id signature + -- Strip off lambda's, these will be arguments + let (args, letexpr) = CoreSyn.collectBinders expr + -- There must be a let at top level + let (CoreSyn.Let (CoreSyn.Rec binds) (CoreSyn.Var res)) = letexpr + + -- Create signal declarations for all binders in the let expression, except + -- for the output port (that will already have an output port declared in + -- the entity). + sig_dec_maybes <- mapM (mkSigDec' . fst) (filter ((/=res).fst) binds) + let sig_decs = Maybe.catMaybes $ sig_dec_maybes + + (statementss, used_entitiess) <- Monad.mapAndUnzipM mkConcSm binds + let statements = concat statementss + let used_entities = concat used_entitiess + let arch = AST.ArchBody (mkVHDLBasicId "structural") (AST.NSimple entity_id) (map AST.BDISD sig_decs) (statements ++ procs') + return (arch, used_entities) + where + procs = [] --map mkStateProcSm [] -- (makeStatePairs flatfunc) + procs' = map AST.CSPSm procs + -- mkSigDec only uses vsTypes from the state + mkSigDec' = mkSigDec + +-- | Transforms a core binding into a VHDL concurrent statement +mkConcSm :: + (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The binding to process + -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr]) + -- ^ The corresponding VHDL concurrent statements and entities + -- instantiated. + + +-- Ignore Cast expressions, they should not longer have any meaning as long as +-- the type works out. +mkConcSm (bndr, CoreSyn.Cast expr ty) = mkConcSm (bndr, expr) + +-- Simple a = b assignments are just like applications, but without arguments. +-- We can't just generate an unconditional assignment here, since b might be a +-- top level binding (e.g., a function with no arguments). +mkConcSm (bndr, CoreSyn.Var v) = do + genApplication (Left bndr) v [] + +mkConcSm (bndr, app@(CoreSyn.App _ _))= do + let (CoreSyn.Var f, args) = CoreSyn.collectArgs app + let valargs = get_val_args (Var.varType f) args + genApplication (Left bndr) f (map Left valargs) + +-- A single alt case must be a selector. This means thee scrutinee is a simple +-- variable, the alternative is a dataalt with a single non-wild binder that +-- is also returned. +mkConcSm (bndr, expr@(CoreSyn.Case (CoreSyn.Var scrut) b ty [alt])) = + case alt of + (CoreSyn.DataAlt dc, bndrs, (CoreSyn.Var sel_bndr)) -> do + case List.elemIndex sel_bndr bndrs of + Just i -> do + 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 + return ([mkUncondAssign (Left bndr) sel_expr], []) + Nothing -> error $ "\nVHDL.mkConcSM: Not in normal form: Not a selector case:\n" ++ (pprString expr) + + _ -> error $ "\nVHDL.mkConcSM: Not in normal form: Not a selector case:\n" ++ (pprString expr) + +-- Multiple case alt are be conditional assignments and have only wild +-- binders in the alts and only variables in the case values and a variable +-- for a scrutinee. We check the constructor of the second alt, since the +-- first is the default case, if there is any. +mkConcSm (bndr, (CoreSyn.Case (CoreSyn.Var scrut) b ty [(_, _, CoreSyn.Var false), (con, _, CoreSyn.Var true)])) = do + scrut' <- MonadState.lift vsType $ varToVHDLExpr scrut + let cond_expr = scrut' AST.:=: (altconToVHDLExpr con) + true_expr <- MonadState.lift vsType $ varToVHDLExpr true + false_expr <- MonadState.lift vsType $ varToVHDLExpr false + return ([mkCondAssign (Left bndr) cond_expr true_expr false_expr], []) + +mkConcSm (_, (CoreSyn.Case (CoreSyn.Var _) _ _ alts)) = error "\nVHDL.mkConcSm: Not in normal form: Case statement with more than two alternatives" +mkConcSm (_, CoreSyn.Case _ _ _ _) = error "\nVHDL.mkConcSm: Not in normal form: Case statement has does not have a simple variable as scrutinee" +mkConcSm (bndr, expr) = error $ "\nVHDL.mkConcSM: Unsupported binding in let expression: " ++ pprString bndr ++ " = " ++ pprString expr ----------------------------------------------------------------------------- -- Functions to generate VHDL for builtin functions @@ -40,6 +200,15 @@ genExprArgs wrap dst func args = do eitherCoreOrExprArgs :: [Either CoreSyn.CoreExpr AST.Expr] -> VHDLSession [AST.Expr] eitherCoreOrExprArgs args = mapM (Either.either ((MonadState.lift vsType) . varToVHDLExpr . exprToVar) return) args +-- A function to wrap a builder-like function that generates no component +-- instantiations +genNoInsts :: + (dst -> func -> args -> TranslatorSession [AST.ConcSm]) + -> (dst -> func -> args -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])) +genNoInsts wrap dst func args = do + concsms <- wrap dst func args + return (concsms, []) + -- | A function to wrap a builder-like function that expects its arguments to -- be variables. genVarArgs :: @@ -75,19 +244,19 @@ genExprRes wrap dst func args = do -- | Generate a binary operator application. The first argument should be a -- constructor from the AST.Expr type, e.g. AST.And. genOperator2 :: (AST.Expr -> AST.Expr -> AST.Expr) -> BuiltinBuilder -genOperator2 op = genExprArgs $ genExprRes (genOperator2' op) +genOperator2 op = genNoInsts $ genExprArgs $ genExprRes (genOperator2' op) genOperator2' :: (AST.Expr -> AST.Expr -> AST.Expr) -> dst -> CoreSyn.CoreBndr -> [AST.Expr] -> VHDLSession AST.Expr genOperator2' op _ f [arg1, arg2] = return $ op arg1 arg2 -- | Generate a unary operator application genOperator1 :: (AST.Expr -> AST.Expr) -> BuiltinBuilder -genOperator1 op = genExprArgs $ genExprRes (genOperator1' op) +genOperator1 op = genNoInsts $ genExprArgs $ genExprRes (genOperator1' op) genOperator1' :: (AST.Expr -> AST.Expr) -> dst -> CoreSyn.CoreBndr -> [AST.Expr] -> VHDLSession AST.Expr genOperator1' op _ f [arg] = return $ op arg -- | Generate a unary operator application genNegation :: BuiltinBuilder -genNegation = genVarArgs $ genExprRes genNegation' +genNegation = genNoInsts $ genVarArgs $ genExprRes genNegation' genNegation' :: dst -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession AST.Expr genNegation' _ f [arg] = do arg1 <- MonadState.lift vsType $ varToVHDLExpr arg @@ -101,7 +270,7 @@ genNegation' _ f [arg] = do -- | Generate a function call from the destination binder, function name and a -- list of expressions (its arguments) genFCall :: Bool -> BuiltinBuilder -genFCall switch = genExprArgs $ genExprRes (genFCall' switch) +genFCall switch = genNoInsts $ 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 @@ -112,7 +281,7 @@ genFCall' switch (Left res) f args = do genFCall' _ (Right name) _ _ = error $ "\nGenerate.genFCall': Cannot generate builtin function call assigned to a VHDLName: " ++ show name genFromSizedWord :: BuiltinBuilder -genFromSizedWord = genExprArgs $ genExprRes genFromSizedWord' +genFromSizedWord = genNoInsts $ genExprArgs $ genExprRes genFromSizedWord' genFromSizedWord' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> VHDLSession AST.Expr genFromSizedWord' (Left res) f args = do let fname = varToString f @@ -121,7 +290,7 @@ genFromSizedWord' (Left res) f args = do genFromSizedWord' (Right name) _ _ = error $ "\nGenerate.genFromSizedWord': Cannot generate builtin function call assigned to a VHDLName: " ++ show name genResize :: BuiltinBuilder -genResize = genExprArgs $ genExprRes genResize' +genResize = genNoInsts $ genExprArgs $ genExprRes genResize' genResize' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> VHDLSession AST.Expr genResize' (Left res) f [arg] = do { ; let { ty = Var.varType res @@ -139,7 +308,7 @@ genResize' (Right name) _ _ = error $ "\nGenerate.genFromSizedWord': Cannot gene -- FIXME: I'm calling genLitArgs which is very specific function, -- which needs to be fixed as well genFromInteger :: BuiltinBuilder -genFromInteger = genLitArgs $ genExprRes genFromInteger' +genFromInteger = genNoInsts $ genLitArgs $ genExprRes genFromInteger' genFromInteger' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [Literal.Literal] -> VHDLSession AST.Expr genFromInteger' (Left res) f lits = do { ; let { ty = Var.varType res @@ -159,6 +328,7 @@ genFromInteger' (Right name) _ _ = error $ "\nGenerate.genFromInteger': Cannot g genSizedInt :: BuiltinBuilder genSizedInt = genFromInteger +{- -- | Generate a Builder for the builtin datacon TFVec genTFVec :: BuiltinBuilder genTFVec (Left res) f [Left (CoreSyn.Let (CoreSyn.Rec letBinders) letRes)] = do { @@ -228,7 +398,7 @@ genTFVec (Left res) f [Left app@(CoreSyn.App _ _)] = do { genTFVec (Left name) _ [Left xs] = error $ "\nGenerate.genTFVec: Cannot generate TFVec: " ++ show name ++ ", with elems:\n" ++ show xs ++ "\n" ++ pprString xs genTFVec (Right name) _ _ = error $ "\nGenerate.genTFVec: Cannot generate TFVec assigned to VHDLName: " ++ show name - +-} -- | Generate a generate statement for the builtin function "map" genMap :: BuiltinBuilder genMap (Left res) f [Left mapped_f, Left (CoreSyn.Var arg)] = do { @@ -251,16 +421,16 @@ genMap (Left res) f [Left mapped_f, Left (CoreSyn.Var arg)] = do { ; (CoreSyn.Var real_f, already_mapped_args) = CoreSyn.collectArgs mapped_f ; valargs = get_val_args (Var.varType real_f) already_mapped_args } ; - ; app_concsms <- genApplication (Right resname) real_f (map Left valargs ++ [Right argexpr]) + ; (app_concsms, used) <- genApplication (Right resname) real_f (map Left valargs ++ [Right argexpr]) -- Return the generate statement - ; return [AST.CSGSm $ AST.GenerateSm label genScheme [] app_concsms] + ; return ([AST.CSGSm $ AST.GenerateSm label genScheme [] app_concsms], used) } genMap' (Right name) _ _ = error $ "\nGenerate.genMap': Cannot generate map function call assigned to a VHDLName: " ++ show name genZipWith :: BuiltinBuilder genZipWith = genVarArgs genZipWith' -genZipWith' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm] +genZipWith' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession ([AST.ConcSm], [CoreSyn.CoreBndr]) genZipWith' (Left res) f args@[zipped_f, arg1, arg2] = do { -- Setup the generate scheme ; len <- MonadState.lift vsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) res @@ -276,9 +446,9 @@ genZipWith' (Left res) f args@[zipped_f, arg1, arg2] = do { ; argexpr1 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg1) n_expr ; argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg2) n_expr } ; - ; app_concsms <- genApplication (Right resname) zipped_f [Right argexpr1, Right argexpr2] + ; (app_concsms, used) <- genApplication (Right resname) zipped_f [Right argexpr1, Right argexpr2] -- Return the generate functions - ; return [AST.CSGSm $ AST.GenerateSm label genScheme [] app_concsms] + ; return ([AST.CSGSm $ AST.GenerateSm label genScheme [] app_concsms], used) } genFoldl :: BuiltinBuilder @@ -290,16 +460,16 @@ genFoldr = genFold False genFold :: Bool -> BuiltinBuilder genFold left = genVarArgs (genFold' left) -genFold' :: Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm] +genFold' :: Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession ([AST.ConcSm], [CoreSyn.CoreBndr]) genFold' left res f args@[folded_f , start ,vec]= do len <- MonadState.lift vsType $ tfp_to_int $ (tfvec_len_ty (Var.varType vec)) genFold'' len left res f args -genFold'' :: Int -> Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm] +genFold'' :: Int -> Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession ([AST.ConcSm], [CoreSyn.CoreBndr]) -- Special case for an empty input vector, just assign start to res genFold'' len left (Left res) _ [_, start, vec] | len == 0 = do arg <- MonadState.lift vsType $ varToVHDLExpr start - return [mkUncondAssign (Left res) arg] + return ([mkUncondAssign (Left res) arg], []) genFold'' len left (Left res) f [folded_f, start, vec] = do -- The vector length @@ -322,14 +492,15 @@ genFold'' len left (Left res) f [folded_f, start, vec] = do -- Make the intermediate vector let tmp_dec = AST.BDISD $ AST.SigDec tmp_id tmp_vhdl_ty Nothing -- Create the generate statement - cells <- sequence [genFirstCell, genOtherCell] + cells' <- sequence [genFirstCell, genOtherCell] + let (cells, useds) = unzip cells' let gen_sm = AST.GenerateSm gen_label gen_scheme [] (map AST.CSGSm cells) -- Assign tmp[len-1] or tmp[0] to res let out_assign = mkUncondAssign (Left res) $ vhdlNameToVHDLExpr (if left then (mkIndexedName tmp_name (AST.PrimLit $ show (len-1))) else (mkIndexedName tmp_name (AST.PrimLit "0"))) let block = AST.BlockSm block_label [] (AST.PMapAspect []) [tmp_dec] [AST.CSGSm gen_sm, out_assign] - return [AST.CSBSm block] + return ([AST.CSBSm block], concat useds) where -- An id for the counter n_id = mkVHDLBasicId "n" @@ -341,7 +512,7 @@ genFold'' len left (Left res) f [folded_f, start, vec] = do tmp_id = mkVHDLBasicId "tmp" tmp_name = AST.NSimple tmp_id -- Generate parts of the fold - genFirstCell, genOtherCell :: VHDLSession AST.GenerateSm + genFirstCell, genOtherCell :: VHDLSession (AST.GenerateSm, [CoreSyn.CoreBndr]) genFirstCell = do len <- MonadState.lift vsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) vec let cond_label = mkVHDLExtId "firstcell" @@ -354,13 +525,13 @@ genFold'' len left (Left res) f [folded_f, start, vec] = do argexpr1 <- MonadState.lift vsType $ varToVHDLExpr start -- Input from vec[current n] let argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName vec) n_cur - app_concsms <- genApplication (Right resname) folded_f ( if left then + (app_concsms, used) <- genApplication (Right resname) folded_f ( if left then [Right argexpr1, Right argexpr2] else [Right argexpr2, Right argexpr1] ) -- Return the conditional generate part - return $ AST.GenerateSm cond_label cond_scheme [] app_concsms + return $ (AST.GenerateSm cond_label cond_scheme [] app_concsms, used) genOtherCell = do len <- MonadState.lift vsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) vec @@ -374,17 +545,17 @@ genFold'' len left (Left res) f [folded_f, start, vec] = do let argexpr1 = vhdlNameToVHDLExpr $ mkIndexedName tmp_name n_prev -- Input from vec[current n] let argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName vec) n_cur - app_concsms <- genApplication (Right resname) folded_f ( if left then + (app_concsms, used) <- genApplication (Right resname) folded_f ( if left then [Right argexpr1, Right argexpr2] else [Right argexpr2, Right argexpr1] ) -- Return the conditional generate part - return $ AST.GenerateSm cond_label cond_scheme [] app_concsms + return $ (AST.GenerateSm cond_label cond_scheme [] app_concsms, used) -- | Generate a generate statement for the builtin function "zip" genZip :: BuiltinBuilder -genZip = genVarArgs genZip' +genZip = genNoInsts $ genVarArgs genZip' genZip' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm] genZip' (Left res) f args@[arg1, arg2] = do { -- Setup the generate scheme @@ -411,7 +582,7 @@ genZip' (Left res) f args@[arg1, arg2] = do { -- | Generate a generate statement for the builtin function "unzip" genUnzip :: BuiltinBuilder -genUnzip = genVarArgs genUnzip' +genUnzip = genNoInsts $ genVarArgs genUnzip' genUnzip' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm] genUnzip' (Left res) f args@[arg] = do { -- Setup the generate scheme @@ -439,7 +610,7 @@ genUnzip' (Left res) f args@[arg] = do { } genCopy :: BuiltinBuilder -genCopy = genVarArgs genCopy' +genCopy = genNoInsts $ genVarArgs genCopy' genCopy' :: (Either CoreSyn.CoreBndr AST.VHDLName ) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm] genCopy' (Left res) f args@[arg] = let @@ -450,7 +621,7 @@ genCopy' (Left res) f args@[arg] = return [out_assign] genConcat :: BuiltinBuilder -genConcat = genVarArgs genConcat' +genConcat = genNoInsts $ genVarArgs genConcat' genConcat' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm] genConcat' (Left res) f args@[arg] = do { -- Setup the generate scheme @@ -493,14 +664,14 @@ genGenerate = genIterateOrGenerate False genIterateOrGenerate :: Bool -> BuiltinBuilder genIterateOrGenerate iter = genVarArgs (genIterateOrGenerate' iter) -genIterateOrGenerate' :: Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm] +genIterateOrGenerate' :: Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession ([AST.ConcSm], [CoreSyn.CoreBndr]) genIterateOrGenerate' iter (Left res) f args = do len <- MonadState.lift vsType $ tfp_to_int ((tfvec_len_ty . Var.varType) res) genIterateOrGenerate'' len iter (Left res) f args -genIterateOrGenerate'' :: Int -> Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm] +genIterateOrGenerate'' :: Int -> Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession ([AST.ConcSm], [CoreSyn.CoreBndr]) -- Special case for an empty input vector, just assign start to res -genIterateOrGenerate'' len iter (Left res) _ [app_f, start] | len == 0 = return [mkUncondAssign (Left res) (AST.PrimLit "\"\"")] +genIterateOrGenerate'' len iter (Left res) _ [app_f, start] | len == 0 = return ([mkUncondAssign (Left res) (AST.PrimLit "\"\"")], []) genIterateOrGenerate'' len iter (Left res) f [app_f, start] = do -- The vector length @@ -522,12 +693,13 @@ genIterateOrGenerate'' len iter (Left res) f [app_f, start] = do -- Make the intermediate vector let tmp_dec = AST.BDISD $ AST.SigDec tmp_id tmp_vhdl_ty Nothing -- Create the generate statement - cells <- sequence [genFirstCell, genOtherCell] + cells' <- sequence [genFirstCell, genOtherCell] + let (cells, useds) = unzip cells' let gen_sm = AST.GenerateSm gen_label gen_scheme [] (map AST.CSGSm cells) -- Assign tmp[len-1] or tmp[0] to res let out_assign = mkUncondAssign (Left res) $ vhdlNameToVHDLExpr tmp_name let block = AST.BlockSm block_label [] (AST.PMapAspect []) [tmp_dec] [AST.CSGSm gen_sm, out_assign] - return [AST.CSBSm block] + return ([AST.CSBSm block], concat useds) where -- An id for the counter n_id = mkVHDLBasicId "n" @@ -538,7 +710,7 @@ genIterateOrGenerate'' len iter (Left res) f [app_f, start] = do tmp_id = mkVHDLBasicId "tmp" tmp_name = AST.NSimple tmp_id -- Generate parts of the fold - genFirstCell, genOtherCell :: VHDLSession AST.GenerateSm + genFirstCell, genOtherCell :: VHDLSession (AST.GenerateSm, [CoreSyn.CoreBndr]) genFirstCell = do let cond_label = mkVHDLExtId "firstcell" -- if n == 0 or n == len-1 @@ -548,13 +720,14 @@ genIterateOrGenerate'' len iter (Left res) f [app_f, start] = do -- Input from start argexpr <- MonadState.lift vsType $ varToVHDLExpr start let startassign = mkUncondAssign (Right resname) argexpr - app_concsms <- genApplication (Right resname) app_f [Right argexpr] + (app_concsms, used) <- genApplication (Right resname) app_f [Right argexpr] -- Return the conditional generate part - return $ AST.GenerateSm cond_label cond_scheme [] (if iter then + let gensm = AST.GenerateSm cond_label cond_scheme [] (if iter then [startassign] else app_concsms ) + return (gensm, used) genOtherCell = do let cond_label = mkVHDLExtId "othercell" @@ -564,9 +737,9 @@ genIterateOrGenerate'' len iter (Left res) f [app_f, start] = do let resname = mkIndexedName tmp_name n_cur -- Input from tmp[previous n] let argexpr = vhdlNameToVHDLExpr $ mkIndexedName tmp_name n_prev - app_concsms <- genApplication (Right resname) app_f [Right argexpr] + (app_concsms, used) <- genApplication (Right resname) app_f [Right argexpr] -- Return the conditional generate part - return $ AST.GenerateSm cond_label cond_scheme [] app_concsms + return $ (AST.GenerateSm cond_label cond_scheme [] app_concsms, used) ----------------------------------------------------------------------------- @@ -576,31 +749,32 @@ genApplication :: (Either CoreSyn.CoreBndr AST.VHDLName) -- ^ Where to store the result? -> CoreSyn.CoreBndr -- ^ The function to apply -> [Either CoreSyn.CoreExpr AST.Expr] -- ^ The arguments to apply - -> VHDLSession [AST.ConcSm] -- ^ The resulting concurrent statements + -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr]) + -- ^ The corresponding VHDL concurrent statements and entities + -- instantiated. genApplication dst f args = do case Var.isGlobalId f of - False -> do - signatures <- getA vsSignatures - -- This is a local id, so it should be a function whose definition we - -- have and which can be turned into a component instantiation. - case (Map.lookup f signatures) of - Just signature -> do - args' <- eitherCoreOrExprArgs args - -- We have a signature, this is a top level binding. Generate a + False -> do + top <- isTopLevelBinder f + case top of + True -> do + -- Local binder that references a top level binding. Generate a -- component instantiation. + signature <- getEntity f + args' <- eitherCoreOrExprArgs args let entity_id = ent_id signature -- TODO: Using show here isn't really pretty, but we'll need some -- unique-ish value... let label = "comp_ins_" ++ (either show prettyShow) dst let portmaps = mkAssocElems args' ((either varToVHDLName id) dst) signature - return [mkComponentInst label entity_id portmaps] - Nothing -> do - -- No signature, so this must be a local variable reference. It - -- should have a representable type (and thus, no arguments) and a - -- signal should be generated for it. Just generate an - -- unconditional assignment here. + return ([mkComponentInst label entity_id portmaps], [f]) + False -> do + -- Not a top level binder, so this must be a local variable reference. + -- It should have a representable type (and thus, no arguments) and a + -- signal should be generated for it. Just generate an unconditional + -- assignment here. f' <- MonadState.lift vsType $ varToVHDLExpr f - return $ [mkUncondAssign dst f'] + return $ ([mkUncondAssign dst f'], []) True -> case Var.idDetails f of IdInfo.DataConWorkId dc -> case dst of @@ -609,7 +783,7 @@ genApplication dst f args = do -- We have the bndr, so we can get at the type labels <- MonadState.lift vsType $ getFieldLabels (Var.varType bndr) args' <- eitherCoreOrExprArgs args - return $ zipWith mkassign labels $ args' + return $ (zipWith mkassign labels $ args', []) where mkassign :: AST.VHDLId -> AST.Expr -> AST.ConcSm mkassign label arg = @@ -1041,6 +1215,19 @@ genUnconsVectorFuns elemTM vectorTM = -- A table of builtin functions ----------------------------------------------------------------------------- +-- A function that generates VHDL for a builtin function +type BuiltinBuilder = + (Either CoreSyn.CoreBndr AST.VHDLName) -- ^ The destination signal and it's original type + -> CoreSyn.CoreBndr -- ^ The function called + -> [Either CoreSyn.CoreExpr AST.Expr] -- ^ The value arguments passed (excluding type and + -- dictionary arguments). + -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr]) + -- ^ The corresponding VHDL concurrent statements and entities + -- instantiated. + +-- A map of a builtin function to VHDL function builder +type NameTable = Map.Map String (Int, BuiltinBuilder ) + -- | The builtin functions we support. Maps a name to an argument count and a -- builder function. globalNameTable :: NameTable @@ -1091,5 +1278,5 @@ globalNameTable = Map.fromList , (fromIntegerId , (1, genFromInteger ) ) , (resizeId , (1, genResize ) ) , (sizedIntId , (1, genSizedInt ) ) - , (tfvecId , (1, genTFVec ) ) + --, (tfvecId , (1, genTFVec ) ) ] diff --git "a/c\316\273ash/CLasH/VHDL/VHDLTools.hs" "b/c\316\273ash/CLasH/VHDL/VHDLTools.hs" index 9c10afd..3991a3f 100644 --- "a/c\316\273ash/CLasH/VHDL/VHDLTools.hs" +++ "b/c\316\273ash/CLasH/VHDL/VHDLTools.hs" @@ -30,6 +30,7 @@ import qualified CoreSubst -- Local imports import CLasH.VHDL.VHDLTypes +import CLasH.Translator.TranslatorTypes import CLasH.Utils.Core.CoreTools import CLasH.Utils.Pretty import CLasH.VHDL.Constants diff --git "a/c\316\273ash/CLasH/VHDL/VHDLTypes.hs" "b/c\316\273ash/CLasH/VHDL/VHDLTypes.hs" index 52adab7..64fb7ab 100644 --- "a/c\316\273ash/CLasH/VHDL/VHDLTypes.hs" +++ "b/c\316\273ash/CLasH/VHDL/VHDLTypes.hs" @@ -11,8 +11,6 @@ import Data.Accessor import qualified Data.Accessor.Template -- GHC API imports -import qualified Type -import qualified CoreSyn import qualified HscTypes -- ForSyDe imports @@ -29,75 +27,10 @@ type Port = (AST.VHDLId, AST.TypeMark) data Entity = Entity { ent_id :: AST.VHDLId, -- The id of the entity ent_args :: [Port], -- A mapping of each function argument to port names - ent_res :: Port -- A mapping of the function result to port names + ent_res :: Port, -- A mapping of the function result to port names + ent_dec :: AST.EntityDec -- ^ The complete entity declaration } deriving (Show); --- A orderable equivalent of CoreSyn's Type for use as a map key -newtype OrdType = OrdType { getType :: 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 - -data HType = StdType OrdType | - ADTType String [HType] | - VecType Int HType | - SizedWType Int | - RangedWType Int | - SizedIType Int | - BuiltinType String - deriving (Eq, Ord) - --- A map of a Core type to the corresponding type name -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. -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 - -type TfpIntMap = Map.Map OrdType Int - -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, - vsTfpInts_ :: TfpIntMap, - vsHscEnv_ :: HscTypes.HscEnv -} --- Derive accessors -$( Data.Accessor.Template.deriveAccessors ''TypeState ) --- 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 -} - --- Derive accessors -$( Data.Accessor.Template.deriveAccessors ''VHDLState ) - --- | The state containing a VHDL Session -type VHDLSession = State.State VHDLState - --- A function that generates VHDL for a builtin function -type BuiltinBuilder = - (Either CoreSyn.CoreBndr AST.VHDLName) -- ^ The destination signal and it's original type - -> CoreSyn.CoreBndr -- ^ The function called - -> [Either CoreSyn.CoreExpr AST.Expr] -- ^ The value arguments passed (excluding type and - -- dictionary arguments). - -> VHDLSession [AST.ConcSm] -- ^ The resulting concurrent statements. - --- A map of a builtin function to VHDL function builder -type NameTable = Map.Map String (Int, BuiltinBuilder ) +type Architecture = AST.ArchBody -- vim: set ts=8 sw=2 sts=2 expandtab: -- 2.30.2