From: Matthijs Kooijman Date: Wed, 5 Aug 2009 15:10:41 +0000 (+0200) Subject: Merge branch 'master' of git://github.com/christiaanb/clash into cλash X-Git-Url: https://git.stderr.nl/gitweb?a=commitdiff_plain;h=d42006e5be8a3d6e3970b84767856b77d00f7f73;hp=68452976b782fcf291a678330ca3a9703e8c7c35;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git Merge branch 'master' of git://github.com/christiaanb/clash into cλash * 'master' of git://github.com/christiaanb/clash: Fix builtin functions (!),take and RangedWord Conflicts: cλash/CLasH/VHDL/Generate.hs --- diff --git "a/c\316\273ash/CLasH/Normalize.hs" "b/c\316\273ash/CLasH/Normalize.hs" index 8ec195b..8b35bb9 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, normalizeExpr) where -- Standard modules import Debug.Trace @@ -34,9 +34,12 @@ 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.Core.BinderTools import CLasH.Utils.Pretty -------------------------------- @@ -49,7 +52,7 @@ import CLasH.Utils.Pretty eta, etatop :: Transform eta expr | is_fun expr && not (is_lam expr) = do let arg_ty = (fst . Type.splitFunTy . CoreUtils.exprType) expr - id <- mkInternalVar "param" arg_ty + id <- Trans.lift $ mkInternalVar "param" arg_ty change (Lam id (App expr (Var id))) -- Leave all other expressions unchanged eta e = return e @@ -110,7 +113,7 @@ letsimpl expr@(Let (Rec binds) res) = do then do -- If the result is not a local var already (to prevent loops with -- ourselves), extract it. - id <- mkInternalVar "foo" (CoreUtils.exprType res) + id <- Trans.lift $ mkInternalVar "foo" (CoreUtils.exprType res) let bind = (id, res) change $ Let (Rec (bind:binds)) (Var id) else @@ -186,7 +189,7 @@ scrutsimpl expr@(Case scrut b ty alts) = do repr <- isRepr scrut if repr then do - id <- mkInternalVar "scrut" (CoreUtils.exprType scrut) + id <- Trans.lift $ mkInternalVar "scrut" (CoreUtils.exprType scrut) change $ Let (Rec [(id, scrut)]) (Case (Var id) b ty alts) else return expr @@ -260,7 +263,7 @@ casesimpl expr@(Case scrut b ty alts) = do -- Create on new binder that will actually capture a value in this -- case statement, and return it. let bty = (Id.idType b) - id <- mkInternalVar "sel" bty + id <- Trans.lift $ mkInternalVar "sel" bty let binders = take i wildbndrs ++ [id] ++ drop (i+1) wildbndrs let caseexpr = Case scrut b bty [(con, binders, Var id)] return (wildbndrs!!i, Just (b, caseexpr)) @@ -280,7 +283,7 @@ casesimpl expr@(Case scrut b ty alts) = do -- prevent loops with inlinenonrep). if (not uses_bndrs) && (not local_var) && repr then do - id <- mkInternalVar "caseval" (CoreUtils.exprType expr) + id <- Trans.lift $ mkInternalVar "caseval" (CoreUtils.exprType expr) -- We don't flag a change here, since casevalsimpl will do that above -- based on Just we return here. return $ (Just (id, expr), Var id) @@ -320,7 +323,7 @@ appsimpl expr@(App f arg) = do local_var <- Trans.lift $ is_local_var arg if repr && not local_var then do -- Extract representable arguments - id <- mkInternalVar "arg" (CoreUtils.exprType arg) + id <- Trans.lift $ mkInternalVar "arg" (CoreUtils.exprType arg) change $ Let (Rec [(id, arg)]) (App f (Var id)) else -- Leave non-representable arguments unchanged return expr @@ -356,7 +359,7 @@ argprop expr@(App _ _) | is_var fexpr = do -- the old body applied to some arguments. let newbody = MkCore.mkCoreLams newparams (MkCore.mkCoreApps body oldargs) -- Create a new function with the same name but a new body - newf <- mkFunction f newbody + newf <- Trans.lift $ mkFunction f newbody -- Replace the original application with one of the new function to the -- new arguments. change $ MkCore.mkCoreApps (Var newf) newargs @@ -402,7 +405,7 @@ argprop expr@(App _ _) | is_var fexpr = do -- Representable types will not be propagated, and arguments with free -- type variables will be propagated later. -- TODO: preserve original naming? - id <- mkBinderFor arg "param" + id <- Trans.lift $ mkBinderFor arg "param" -- Just pass the original argument to the new function, which binds it -- to a new id and just pass that new id to the old function body. return ([arg], [id], mkReferenceTo id) @@ -449,7 +452,7 @@ funextract expr@(App _ _) | is_var fexpr = do -- by the argument expression. let free_vars = VarSet.varSetElems $ CoreFVs.exprFreeVars arg let body = MkCore.mkCoreLams free_vars arg - id <- mkBinderFor body "fun" + id <- Trans.lift $ mkBinderFor body "fun" Trans.lift $ addGlobalBind id body -- Replace the argument with a reference to the new function, applied to -- all vars it uses. @@ -472,78 +475,45 @@ 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 - -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) - -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!" +-- | Returns the normalized version of the given function. +getNormalized :: + CoreBndr -- ^ The function to get + -> TranslatorSession CoreExpr -- The normalized function body + +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 + normalizeExpr (show bndr) expr + +-- | Normalize an expression +normalizeExpr :: + String -- ^ What are we normalizing? For debug output only. + -> CoreSyn.CoreExpr -- ^ The expression to normalize + -> TranslatorSession CoreSyn.CoreExpr -- ^ The normalized expression + +normalizeExpr what 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 " ++ what ++ "\nBefore:\n\n" ++ showSDoc ( ppr expr' ) ++ "\n") $ return () + expr'' <- dotransforms transforms expr' + trace ("\nAfter:\n\n" ++ showSDoc ( ppr expr')) $ return () + return expr'' + +-- | 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..b26cb74 100644 --- "a/c\316\273ash/CLasH/Normalize/NormalizeTools.hs" +++ "b/c\316\273ash/CLasH/Normalize/NormalizeTools.hs" @@ -3,6 +3,7 @@ -- This module provides functions for program transformations. -- module CLasH.Normalize.NormalizeTools where + -- Standard modules import Debug.Trace import qualified List @@ -19,88 +20,17 @@ import Data.Accessor.MonadState as MonadState -- GHC API import CoreSyn -import qualified UniqSupply -import qualified Unique -import qualified OccName -import qualified Name -import qualified Var -import qualified SrcLoc -import qualified Type -import qualified IdInfo -import qualified CoreUtils import qualified CoreSubst -import qualified VarSet -import qualified HscTypes +import qualified CoreUtils 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 --- Create a new internal var with the given name and type. A Unique is --- appended to the given name, to ensure uniqueness (not strictly neccesary, --- since the Unique is also stored in the name, but this ensures variable --- names are unique in the output). -mkInternalVar :: String -> Type.Type -> TransformMonad Var.Var -mkInternalVar str ty = Trans.lift (mkInternalVar' str ty) - -mkInternalVar' :: String -> Type.Type -> TransformSession Var.Var -mkInternalVar' str ty = do - uniq <- mkUnique' - let occname = OccName.mkVarOcc (str ++ show uniq) - let name = Name.mkInternalName uniq occname SrcLoc.noSrcSpan - return $ Var.mkLocalVar IdInfo.VanillaId name ty IdInfo.vanillaIdInfo - --- Create a new type variable with the given name and kind. A Unique is --- appended to the given name, to ensure uniqueness (not strictly neccesary, --- since the Unique is also stored in the name, but this ensures variable --- names are unique in the output). -mkTypeVar :: String -> Type.Kind -> TransformMonad Var.Var -mkTypeVar str kind = Trans.lift (mkTypeVar' str kind) - -mkTypeVar' :: String -> Type.Kind -> TransformSession Var.Var -mkTypeVar' str kind = do - uniq <- mkUnique' - let occname = OccName.mkVarOcc (str ++ show uniq) - let name = Name.mkInternalName uniq occname SrcLoc.noSrcSpan - return $ Var.mkTyVar name kind - --- Creates a binder for the given expression with the given name. This --- works for both value and type level expressions, so it can return a Var or --- TyVar (which is just an alias for Var). -mkBinderFor :: CoreExpr -> String -> TransformMonad Var.Var -mkBinderFor expr string = Trans.lift (mkBinderFor' expr string) - -mkBinderFor' :: CoreExpr -> String -> TransformSession Var.Var -mkBinderFor' (Type ty) string = mkTypeVar' string (Type.typeKind ty) -mkBinderFor' expr string = mkInternalVar' string (CoreUtils.exprType expr) - --- Creates a reference to the given variable. This works for both a normal --- variable as well as a type variable -mkReferenceTo :: Var.Var -> CoreExpr -mkReferenceTo var | Var.isTyVar var = (Type $ Type.mkTyVarTy var) - | otherwise = (Var var) - -cloneVar :: Var.Var -> TransformMonad Var.Var -cloneVar v = do - uniq <- mkUnique - -- Swap out the unique, and reset the IdInfo (I'm not 100% sure what it - -- contains, but vannillaIdInfo is always correct, since it means "no info"). - return $ Var.lazySetIdInfo (Var.setVarUnique v uniq) IdInfo.vanillaIdInfo - --- Creates a new function with the same name as the given binder (but with a --- new unique) and with the given function body. Returns the new binder for --- this function. -mkFunction :: CoreBndr -> CoreExpr -> TransformMonad CoreBndr -mkFunction bndr body = do - let ty = CoreUtils.exprType body - id <- cloneVar bndr - let newid = Var.setVarType id ty - Trans.lift $ addGlobalBind newid body - return newid - -- Apply the given transformation to all expressions in the given expression, -- including the expression itself. everywhere :: (String, Transform) -> Transform @@ -191,7 +121,7 @@ subnotappargs trans (App a b) = do subnotappargs trans expr = subeverywhere (notappargs trans) expr -- Runs each of the transforms repeatedly inside the State monad. -dotransforms :: [Transform] -> CoreExpr -> TransformSession CoreExpr +dotransforms :: [Transform] -> CoreExpr -> TranslatorSession CoreExpr dotransforms transs expr = do (expr', changed) <- Writer.runWriterT $ Monad.foldM (flip ($)) expr transs if Monoid.getAny changed then dotransforms transs expr' else return expr' @@ -228,17 +158,6 @@ change val = do setChanged return val --- Create a new Unique -mkUnique :: TransformMonad Unique.Unique -mkUnique = Trans.lift $ mkUnique' - -mkUnique' :: TransformSession Unique.Unique -mkUnique' = do - us <- getA tsUniqSupply - let (us', us'') = UniqSupply.splitUniqSupply us - putA tsUniqSupply us' - return $ UniqSupply.uniqFromSupply us'' - -- Replace each of the binders given with the coresponding expressions in the -- given expression. substitute :: [(CoreBndr, CoreExpr)] -> CoreExpr -> CoreExpr @@ -258,20 +177,12 @@ 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 isRepr expr = Trans.lift $ MonadState.lift tsType $ VHDLTools.isReprType (CoreUtils.exprType expr) -is_local_var :: CoreSyn.CoreExpr -> TransformSession Bool +is_local_var :: CoreSyn.CoreExpr -> TranslatorSession Bool is_local_var (CoreSyn.Var v) = do bndrs <- getGlobalBinders return $ not $ v `elem` bndrs diff --git "a/c\316\273ash/CLasH/Normalize/NormalizeTypes.hs" "b/c\316\273ash/CLasH/Normalize/NormalizeTypes.hs" index 90589f8..a13ca0f 100644 --- "a/c\316\273ash/CLasH/Normalize/NormalizeTypes.hs" +++ "b/c\316\273ash/CLasH/Normalize/NormalizeTypes.hs" @@ -13,45 +13,17 @@ 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 +-- Wrap a writer around a TranslatorSession, to run a single transformation -- over a single expression and track if the expression was changed. -type TransformMonad = Writer.WriterT Monoid.Any TransformSession +type TransformMonad = Writer.WriterT Monoid.Any TranslatorSession -- | Transforms a CoreExpr and keeps track if it has changed. type Transform = CoreExpr -> TransformMonad CoreExpr - --- Finds the value of a global binding, if available -getGlobalBind :: CoreBndr -> TransformSession (Maybe CoreExpr) -getGlobalBind bndr = do - bindings <- getA tsBindings - return $ Map.lookup bndr bindings - --- Adds a new global binding with the given value -addGlobalBind :: CoreBndr -> CoreExpr -> TransformSession () -addGlobalBind bndr expr = modA tsBindings (Map.insert bndr expr) - --- Returns a list of all global binders -getGlobalBinders :: TransformSession [CoreBndr] -getGlobalBinders = do - bindings <- getA tsBindings - return $ Map.keys bindings diff --git "a/c\316\273ash/CLasH/Translator.hs" "b/c\316\273ash/CLasH/Translator.hs" index 445dd9c..c4daf04 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,10 +26,13 @@ import qualified Language.VHDL.Ppr as Ppr -- Local Imports import CLasH.Normalize +import CLasH.Translator.TranslatorTypes import CLasH.Translator.Annotations +import CLasH.Utils import CLasH.Utils.Core.CoreTools import CLasH.Utils.GhcTools import CLasH.VHDL +import CLasH.VHDL.Testbench -- | Turn Haskell to VHDL, Usings Strings to indicate the Top Entity, Initial -- State and Test Inputs. @@ -39,11 +45,11 @@ makeVHDLStrings :: -> Bool -- ^ Is it stateful? (in case InitState is empty) -> IO () makeVHDLStrings libdir filenames topentity initstate testinput stateful = do - makeVHDL libdir filenames findTopEntity findInitState findTestInput stateful + makeVHDL libdir filenames finder stateful where - findTopEntity = findBind (hasVarName topentity) - findInitState = findBind (hasVarName initstate) - findTestInput = findExpr (hasVarName testinput) + finder = findSpec (hasVarName topentity) + (hasVarName initstate) + (hasVarName testinput) -- | Turn Haskell to VHDL, Using the Annotations for Top Entity, Initial State -- and Test Inputs found in the Files. @@ -53,29 +59,27 @@ makeVHDLAnnotations :: -> Bool -- ^ Is it stateful? (in case InitState is not specified) -> IO () makeVHDLAnnotations libdir filenames stateful = do - makeVHDL libdir filenames findTopEntity findInitState findTestInput stateful + makeVHDL libdir filenames finder stateful where - findTopEntity = findBind (hasCLasHAnnotation isTopEntity) - findInitState = findBind (hasCLasHAnnotation isInitState) - findTestInput = findExpr (hasCLasHAnnotation isTestInput) + finder = findSpec (hasCLasHAnnotation isTopEntity) + (hasCLasHAnnotation isInitState) + (hasCLasHAnnotation isTestInput) -- | Turn Haskell to VHDL, using the given finder functions to find the Top -- Entity, Initial State and Test Inputs in the Haskell Files. makeVHDL :: FilePath -- ^ The GHC Library Dir -> [FilePath] -- ^ The Filenames - -> (HscTypes.CoreModule -> GHC.Ghc (Maybe CoreSyn.CoreBndr)) -- ^ The Top Entity Finder - -> (HscTypes.CoreModule -> GHC.Ghc (Maybe CoreSyn.CoreBndr)) -- ^ The Init State Finder - -> (HscTypes.CoreModule -> GHC.Ghc (Maybe CoreSyn.CoreExpr)) -- ^ The Test Input Finder + -> Finder -> Bool -- ^ Indicates if it is meant to be stateful -> IO () -makeVHDL libdir filenames topEntFinder initStateFinder testInputFinder stateful = do +makeVHDL libdir filenames finder stateful = do -- Load the modules - (cores, top, init, test, env) <- loadModules libdir filenames topEntFinder initStateFinder testInputFinder + (cores, env, specs) <- loadModules libdir filenames (Just finder) -- Translate to VHDL - vhdl <- moduleToVHDL env cores top init test stateful - -- Write VHDL to file - let top_entity = Maybe.fromJust $ head top + vhdl <- moduleToVHDL env cores specs stateful + -- Write VHDL to file. Just use the first entity for the name + let top_entity = (\(t, _, _) -> t) $ head specs let dir = "./vhdl/" ++ (show top_entity) ++ "/" prepareDir dir mapM (writeVHDL dir) vhdl @@ -87,32 +91,40 @@ makeVHDL libdir filenames topEntFinder initStateFinder testInputFinder stateful moduleToVHDL :: HscTypes.HscEnv -- ^ The GHC Environment -> [HscTypes.CoreModule] -- ^ The Core Modules - -> [Maybe CoreSyn.CoreBndr] -- ^ The TopEntity - -> [Maybe CoreSyn.CoreBndr] -- ^ The InitState - -> [Maybe CoreSyn.CoreExpr] -- ^ The TestInput + -> [EntitySpec] -- ^ The entities to generate -> 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 specs stateful = do + 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 + test_binds <- catMaybesM $ Monad.mapM mkTest specs + let topbinds = map (\(top, _, _) -> top) specs + createDesignFiles (topbinds ++ test_binds) + mapM (putStr . render . Ppr.ppr . snd) vhdl + return vhdl + where + mkTest :: EntitySpec -> TranslatorSession (Maybe CoreSyn.CoreBndr) + -- Create a testbench for any entry that has test input + mkTest (_, _, Nothing) = return Nothing + mkTest (top, _, Just input) = do + bndr <- createTestbench Nothing input top + return $ Just bndr + +-- 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..257c543 100644 --- "a/c\316\273ash/CLasH/Translator/TranslatorTypes.hs" +++ "b/c\316\273ash/CLasH/Translator/TranslatorTypes.hs" @@ -5,25 +5,120 @@ {-# 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 GHC +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 specification of an entity we can generate VHDL for. Consists of the +-- binder of the top level entity, an optional initial state and an optional +-- test input. +type EntitySpec = (CoreSyn.CoreBndr, Maybe CoreSyn.CoreExpr, Maybe CoreSyn.CoreExpr) + +-- | A function that knows which parts of a module to compile +type Finder = + HscTypes.CoreModule -- ^ The module to look at + -> GHC.Ghc [EntitySpec] + +----------------------------------------------------------------------------- +-- The TranslatorSession +----------------------------------------------------------------------------- + +-- 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 ) + +-- 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 + +----------------------------------------------------------------------------- +-- Some accessors +----------------------------------------------------------------------------- + +-- 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 + +-- Finds the value of a global binding, if available +getGlobalBind :: CoreSyn.CoreBndr -> TranslatorSession (Maybe CoreSyn.CoreExpr) +getGlobalBind bndr = do + bindings <- getA tsBindings + return $ Map.lookup bndr bindings + +-- Adds a new global binding with the given value +addGlobalBind :: CoreSyn.CoreBndr -> CoreSyn.CoreExpr -> TranslatorSession () +addGlobalBind bndr expr = modA tsBindings (Map.insert bndr expr) -type TranslatorState = State.State TranslatorSession +-- Returns a list of all global binders +getGlobalBinders :: TranslatorSession [CoreSyn.CoreBndr] +getGlobalBinders = do + bindings <- getA tsBindings + return $ Map.keys 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..484fe15 100644 --- "a/c\316\273ash/CLasH/Utils.hs" +++ "b/c\316\273ash/CLasH/Utils.hs" @@ -1,49 +1,46 @@ -module CLasH.Utils - ( listBindings - , listBind - ) where +module CLasH.Utils where -- Standard Imports import qualified Maybe +import Data.Accessor +import qualified Data.Map as Map +import qualified Control.Monad as Monad +import qualified Control.Monad.Trans.State as State -- GHC API -import qualified CoreSyn -import qualified CoreUtils -import qualified HscTypes -import qualified Outputable -import qualified Var -- Local Imports -import CLasH.Utils.GhcTools -import CLasH.Utils.Pretty -listBindings :: FilePath -> [FilePath] -> IO [()] -listBindings libdir filenames = do - (cores,_,_,_,_) <- loadModules libdir filenames bogusFinder bogusFinder bogusFinder - let binds = concat $ map (CoreSyn.flattenBinds . HscTypes.cm_binds) cores - mapM (listBinding) binds - where - bogusFinder = (\x -> return $ Nothing) +-- 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 + +unzipM :: (Monad m) => + m [(a, b)] + -> m ([a], [b]) +unzipM = Monad.liftM unzip + +catMaybesM :: (Monad m) => + m [Maybe a] + -> m [a] +catMaybesM = Monad.liftM Maybe.catMaybes + +concatM :: (Monad m) => + m [[a]] + -> m [a] +concatM = Monad.liftM concat -listBinding :: (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -> IO () -listBinding (b, e) = do - putStr "\nBinder: " - putStr $ show b - putStr "\nType of Binder: \n" - putStr $ Outputable.showSDoc $ Outputable.ppr $ Var.varType b - putStr "\n\nExpression: \n" - putStr $ prettyShow e - putStr "\n\n" - putStr $ Outputable.showSDoc $ Outputable.ppr e - putStr "\n\nType of Expression: \n" - putStr $ Outputable.showSDoc $ Outputable.ppr $ CoreUtils.exprType e - putStr "\n\n" - --- | Show the core structure of the given binds in the given file. -listBind :: FilePath -> [FilePath] -> String -> IO () -listBind libdir filenames name = do - (_,corebind,_,coreexpr,_) <- loadModules libdir filenames bindFinder bindFinder exprFinder - listBinding (Maybe.fromJust $ head corebind, Maybe.fromJust $ head coreexpr) - where - bindFinder = findBind (hasVarName name) - exprFinder = findExpr (hasVarName name) \ No newline at end of file diff --git "a/c\316\273ash/CLasH/Utils/Core/BinderTools.hs" "b/c\316\273ash/CLasH/Utils/Core/BinderTools.hs" new file mode 100644 index 0000000..a072c45 --- /dev/null +++ "b/c\316\273ash/CLasH/Utils/Core/BinderTools.hs" @@ -0,0 +1,88 @@ +-- +-- This module contains functions that manipulate binders in various ways. +-- +module CLasH.Utils.Core.BinderTools where + +-- Standard modules +import Data.Accessor.MonadState as MonadState + +-- GHC API +import CoreSyn +import qualified Type +import qualified UniqSupply +import qualified Unique +import qualified OccName +import qualified Name +import qualified Var +import qualified SrcLoc +import qualified IdInfo +import qualified CoreUtils +import qualified CoreSubst +import qualified VarSet +import qualified HscTypes + +-- Local imports +import Data.Accessor +import Data.Accessor.MonadState as MonadState +import CLasH.Translator.TranslatorTypes + +-- Create a new Unique +mkUnique :: TranslatorSession Unique.Unique +mkUnique = do + us <- getA tsUniqSupply + let (us', us'') = UniqSupply.splitUniqSupply us + putA tsUniqSupply us' + return $ UniqSupply.uniqFromSupply us'' + +-- Create a new internal var with the given name and type. A Unique is +-- appended to the given name, to ensure uniqueness (not strictly neccesary, +-- since the Unique is also stored in the name, but this ensures variable +-- names are unique in the output). +mkInternalVar :: String -> Type.Type -> TranslatorSession Var.Var +mkInternalVar str ty = do + uniq <- mkUnique + let occname = OccName.mkVarOcc (str ++ show uniq) + let name = Name.mkInternalName uniq occname SrcLoc.noSrcSpan + return $ Var.mkLocalVar IdInfo.VanillaId name ty IdInfo.vanillaIdInfo + +-- Create a new type variable with the given name and kind. A Unique is +-- appended to the given name, to ensure uniqueness (not strictly neccesary, +-- since the Unique is also stored in the name, but this ensures variable +-- names are unique in the output). +mkTypeVar :: String -> Type.Kind -> TranslatorSession Var.Var +mkTypeVar str kind = do + uniq <- mkUnique + let occname = OccName.mkVarOcc (str ++ show uniq) + let name = Name.mkInternalName uniq occname SrcLoc.noSrcSpan + return $ Var.mkTyVar name kind + +-- Creates a binder for the given expression with the given name. This +-- works for both value and type level expressions, so it can return a Var or +-- TyVar (which is just an alias for Var). +mkBinderFor :: CoreExpr -> String -> TranslatorSession Var.Var +mkBinderFor (Type ty) string = mkTypeVar string (Type.typeKind ty) +mkBinderFor expr string = mkInternalVar string (CoreUtils.exprType expr) + +-- Creates a reference to the given variable. This works for both a normal +-- variable as well as a type variable +mkReferenceTo :: Var.Var -> CoreExpr +mkReferenceTo var | Var.isTyVar var = (Type $ Type.mkTyVarTy var) + | otherwise = (Var var) + +cloneVar :: Var.Var -> TranslatorSession Var.Var +cloneVar v = do + uniq <- mkUnique + -- Swap out the unique, and reset the IdInfo (I'm not 100% sure what it + -- contains, but vannillaIdInfo is always correct, since it means "no info"). + return $ Var.lazySetIdInfo (Var.setVarUnique v uniq) IdInfo.vanillaIdInfo + +-- Creates a new function with the same name as the given binder (but with a +-- new unique) and with the given function body. Returns the new binder for +-- this function. +mkFunction :: CoreBndr -> CoreExpr -> TranslatorSession CoreBndr +mkFunction bndr body = do + let ty = CoreUtils.exprType body + id <- cloneVar bndr + let newid = Var.setVarType id ty + addGlobalBind newid body + return newid diff --git "a/c\316\273ash/CLasH/Utils/GhcTools.hs" "b/c\316\273ash/CLasH/Utils/GhcTools.hs" index 0c8c559..5a041cc 100644 --- "a/c\316\273ash/CLasH/Utils/GhcTools.hs" +++ "b/c\316\273ash/CLasH/Utils/GhcTools.hs" @@ -9,15 +9,48 @@ import qualified System.IO.Unsafe -- GHC API import qualified Annotations import qualified CoreSyn +import qualified CoreUtils import qualified DynFlags import qualified HscTypes import qualified GHC import qualified Name import qualified Serialized import qualified Var +import qualified Outputable -- Local Imports +import CLasH.Utils.Pretty +import CLasH.Translator.TranslatorTypes import CLasH.Translator.Annotations +import CLasH.Utils + +listBindings :: FilePath -> [FilePath] -> IO [()] +listBindings libdir filenames = do + (cores,_,_) <- loadModules libdir filenames Nothing + let binds = concat $ map (CoreSyn.flattenBinds . HscTypes.cm_binds) cores + mapM (listBinding) binds + +listBinding :: (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -> IO () +listBinding (b, e) = do + putStr "\nBinder: " + putStr $ show b + putStr "\nType of Binder: \n" + putStr $ Outputable.showSDoc $ Outputable.ppr $ Var.varType b + putStr "\n\nExpression: \n" + putStr $ prettyShow e + putStr "\n\n" + putStr $ Outputable.showSDoc $ Outputable.ppr e + putStr "\n\nType of Expression: \n" + putStr $ Outputable.showSDoc $ Outputable.ppr $ CoreUtils.exprType e + putStr "\n\n" + +-- | Show the core structure of the given binds in the given file. +listBind :: FilePath -> [FilePath] -> String -> IO () +listBind libdir filenames name = do + (cores,_,_) <- loadModules libdir filenames Nothing + bindings <- concatM $ mapM (findBinder (hasVarName name)) cores + mapM listBinding bindings + return () -- Change a DynFlag from within the Ghc monad. Strangely enough there seems to -- be no standard function to do exactly this. @@ -46,31 +79,25 @@ unsafeRunGhc libDir m = loadModules :: FilePath -- ^ The GHC Library directory -> [String] -- ^ The files that need to be loaded - -> (HscTypes.CoreModule -> GHC.Ghc (Maybe CoreSyn.CoreBndr)) -- ^ The TopEntity finder - -> (HscTypes.CoreModule -> GHC.Ghc (Maybe CoreSyn.CoreBndr)) -- ^ The InitState finder - -> (HscTypes.CoreModule -> GHC.Ghc (Maybe CoreSyn.CoreExpr)) -- ^ The TestInput finder + -> Maybe Finder -- ^ What entities to build? -> IO ( [HscTypes.CoreModule] - , [Maybe CoreSyn.CoreBndr] - , [Maybe CoreSyn.CoreBndr] - , [Maybe CoreSyn.CoreExpr] , HscTypes.HscEnv - ) -- ^ ( The loaded modules, the TopEntity, the InitState, the TestInput - -- , The Environment corresponding of the loaded modules - -- ) -loadModules libdir filenames topEntLoc initSLoc testLoc = + , [EntitySpec] + ) -- ^ ( The loaded modules, the resulting ghc environment, the entities to build) +loadModules libdir filenames finder = GHC.defaultErrorHandler DynFlags.defaultDynFlags $ do GHC.runGhc (Just libdir) $ do dflags <- GHC.getSessionDynFlags GHC.setSessionDynFlags dflags cores <- mapM GHC.compileToCoreModule filenames env <- GHC.getSession - top_entity <- mapM topEntLoc cores - init_state <- mapM initSLoc cores - test_input <- mapM testLoc cores - return (cores, top_entity, init_state, test_input, env) + specs <- case finder of + Nothing -> return [] + Just f -> concatM $ mapM f cores + return (cores, env, specs) findBind :: - GHC.GhcMonad m => + Monad m => (Var.Var -> m Bool) -> HscTypes.CoreModule -> m (Maybe CoreSyn.CoreBndr) @@ -81,7 +108,7 @@ findBind criteria core = do bndrs -> return $ Just $ fst $ head bndrs findExpr :: - GHC.GhcMonad m => + Monad m => (Var.Var -> m Bool) -> HscTypes.CoreModule -> m (Maybe CoreSyn.CoreExpr) @@ -93,7 +120,7 @@ findExpr criteria core = do -- | Find a binder in module according to a certain criteria findBinder :: - GHC.GhcMonad m => + Monad m => (Var.Var -> m Bool) -- ^ The criteria to filter the binders on -> HscTypes.CoreModule -- ^ The module to be inspected -> m [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)] -- ^ The binders to meet the criteria @@ -119,8 +146,21 @@ hasCLasHAnnotation clashAnn var = do -- | Determine if a binder has a certain name hasVarName :: - GHC.GhcMonad m => + Monad m => String -- ^ The name the binder has to have -> Var.Var -- ^ The Binder -> m Bool -- ^ Indicate if the binder has the name hasVarName lookfor bind = return $ lookfor == (Name.occNameString $ Name.nameOccName $ Name.getName bind) + +-- | Make a complete spec out of a three conditions +findSpec :: + (Var.Var -> GHC.Ghc Bool) -> (Var.Var -> GHC.Ghc Bool) -> (Var.Var -> GHC.Ghc Bool) + -> Finder + +findSpec topc statec testc mod = do + top <- findBind topc mod + state <- findExpr statec mod + test <- findExpr testc mod + case top of + Just t -> return [(t, state, test)] + Nothing -> error $ "Could not find top entity requested" 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..5465df1 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,50 +30,69 @@ 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 import CLasH.Utils.Core.CoreTools import CLasH.VHDL.Constants import CLasH.VHDL.Generate --- import CLasH.VHDL.Testbench +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])] +createLibraryUnit :: + CoreSyn.CoreBndr + -> TranslatorSession (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 - --- | 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 @@ -240,174 +149,3 @@ getSignalId info = (error $ "Unnamed signal? This should not happen!") (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 - -> CoreSyn.CoreBndr -- ^ Top Entity - -> VHDLSession (AST.VHDLId, [AST.LibraryUnit]) -- ^ Testbench -createTestBench mCycles stimuli topEntity = do - ent@(AST.EntityDec id _) <- createTestBenchEntity topEntity - arch <- createTestBenchArch mCycles stimuli topEntity - return (id, [AST.LUEntity ent, AST.LUArch arch]) - - -createTestBenchEntity :: - CoreSyn.CoreBndr -- ^ Top Entity - -> VHDLSession AST.EntityDec -- ^ TB Entity -createTestBenchEntity topEntity = do - signaturemap <- getA vsSignatures - let signature = Maybe.fromMaybe - (error $ "\nTestbench.createTestBenchEntity: Generating testbench for function \n" ++ (pprString topEntity) ++ "\nwithout signature? This should not happen!") - (Map.lookup topEntity signaturemap) - let signaturename = ent_id signature - return $ AST.EntityDec (AST.unsafeIdAppend signaturename "_tb") [] - -createTestBenchArch :: - Maybe Int -- ^ Number of cycles to simulate - -> [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)] -- ^ Imput stimulie - -> CoreSyn.CoreBndr -- ^ Top Entity - -> VHDLSession AST.ArchBody -createTestBenchArch mCycles stimuli topEntity = do - signaturemap <- getA vsSignatures - let signature = Maybe.fromMaybe - (error $ "\nTestbench.createTestBenchArch: Generating testbench for function \n" ++ (pprString topEntity) ++ "\nwithout signature? This should not happen!") - (Map.lookup topEntity signaturemap) - let entId = ent_id signature - iIface = ent_args signature - oIface = ent_res signature - iIds = map fst iIface - oIds = fst oIface - let iDecs = map (\(vId, tm) -> AST.SigDec vId tm Nothing) iIface - let finalIDecs = iDecs ++ - [AST.SigDec clockId std_logicTM (Just $ AST.PrimLit "'0'"), - AST.SigDec resetId std_logicTM (Just $ AST.PrimLit "'0'")] - let oDecs = AST.SigDec (fst oIface) (snd oIface) Nothing - let portmaps = mkAssocElems (map idToVHDLExpr iIds) (AST.NSimple oIds) signature - let mIns = mkComponentInst "totest" entId portmaps - (stimuliAssigns, stimuliDecs, cycles) <- createStimuliAssigns mCycles stimuli (head iIds) - let finalAssigns = (AST.CSSASm (AST.NSimple resetId AST.:<==: - AST.ConWforms [] - (AST.Wform [AST.WformElem (AST.PrimLit "'1'") (Just $ AST.PrimLit "3 ns")]) - Nothing)) : stimuliAssigns - let clkProc = createClkProc - let outputProc = createOutputProc [oIds] - return $ (AST.ArchBody - (AST.unsafeVHDLBasicId "test") - (AST.NSimple $ AST.unsafeIdAppend entId "_tb") - (map AST.BDISD (finalIDecs ++ stimuliDecs ++ [oDecs])) - (mIns : - ( (AST.CSPSm clkProc) : (AST.CSPSm outputProc) : finalAssigns ) ) ) - -createStimuliAssigns :: - Maybe Int -- ^ Number of cycles to simulate - -> [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)] -- ^ Input stimuli - -> AST.VHDLId -- ^ Input signal - -> VHDLSession ([AST.ConcSm], [AST.SigDec], Int) -createStimuliAssigns mCycles [] _ = return ([], [], Maybe.maybe 0 id mCycles) - -createStimuliAssigns mCycles stimuli signal = do - let genWformElem time stim = (AST.WformElem stim (Just $ AST.PrimLit (show time ++ " ns"))) - let inputlen = length stimuli - assigns <- Monad.zipWithM createStimulans stimuli [0..inputlen] - let resvars = (map snd assigns) - sig_dec_maybes <- mapM mkSigDec resvars - let sig_decs = Maybe.catMaybes sig_dec_maybes - outps <- mapM (\x -> MonadState.lift vsType (varToVHDLExpr x)) resvars - let wformelems = zipWith genWformElem [0,10..] outps - let inassign = AST.CSSASm $ AST.NSimple signal AST.:<==: AST.ConWforms [] (AST.Wform wformelems) Nothing - return ((map fst assigns) ++ [inassign], sig_decs, inputlen) - -createStimulans :: (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -> Int -> VHDLSession (AST.ConcSm, Var.Var) -createStimulans (bndr, expr) cycl = do - -- There must be a let at top level - let (CoreSyn.Let (CoreSyn.Rec binds) (Var res)) = expr - stimulansbinds <- Monad.mapM mkConcSm binds - sig_dec_maybes <- mapM (mkSigDec . fst) (filter ((/=res).fst) binds) - let sig_decs = map (AST.BDISD) (Maybe.catMaybes $ sig_dec_maybes) - 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 - where sms = -- wait for 5 ns -- (half a cycle) - [AST.WaitFor $ AST.PrimLit "5 ns", - -- clk <= not clk; - AST.NSimple clockId `AST.SigAssign` - AST.Wform [AST.WformElem (AST.Not (AST.PrimName $ AST.NSimple clockId)) Nothing]] - --- | generate the output process -createOutputProc :: [AST.VHDLId] -- ^ output signal - -> AST.ProcSm -createOutputProc outs = - AST.ProcSm (AST.unsafeVHDLBasicId "writeoutput") - [clockId] - [AST.IfSm clkPred (writeOuts outs) [] Nothing] - where clkPred = AST.PrimName (AST.NAttribute $ AST.AttribName (AST.NSimple clockId) - (AST.NSimple $ eventId) - Nothing ) `AST.And` - (AST.PrimName (AST.NSimple clockId) AST.:=: AST.PrimLit "'1'") - writeOuts :: [AST.VHDLId] -> [AST.SeqSm] - writeOuts [] = [] - writeOuts [i] = [writeOut i (AST.PrimLit "LF")] - writeOuts (i:is) = writeOut i (AST.PrimLit "HT") : writeOuts is - writeOut outSig suffix = - 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 5618532..5360cff 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,173 @@ 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 + -> TranslatorSession 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 signature = Entity vhdl_id args' res' ent_decl + return signature + where + mkMap :: + --[(SignalId, SignalInfo)] + CoreSyn.CoreBndr + -> TranslatorSession Port + 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 tsType $ 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 + -> TranslatorSession (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 tsTypes 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 tsType $ 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 tsType $ varToVHDLExpr scrut + let cond_expr = scrut' AST.:=: (altconToVHDLExpr con) + true_expr <- MonadState.lift tsType $ varToVHDLExpr true + false_expr <- MonadState.lift tsType $ 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 @@ -37,8 +195,17 @@ genExprArgs wrap dst func args = do args' <- eitherCoreOrExprArgs args wrap dst func args' -eitherCoreOrExprArgs :: [Either CoreSyn.CoreExpr AST.Expr] -> VHDLSession [AST.Expr] -eitherCoreOrExprArgs args = mapM (Either.either ((MonadState.lift vsType) . varToVHDLExpr . exprToVar) return) args +eitherCoreOrExprArgs :: [Either CoreSyn.CoreExpr AST.Expr] -> TranslatorSession [AST.Expr] +eitherCoreOrExprArgs args = mapM (Either.either ((MonadState.lift tsType) . 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. @@ -66,8 +233,8 @@ genLitArgs wrap dst func args = wrap dst func args' -- | A function to wrap a builder-like function that produces an expression -- and expects it to be assigned to the destination. genExprRes :: - ((Either CoreSyn.CoreBndr AST.VHDLName) -> func -> [arg] -> VHDLSession AST.Expr) - -> ((Either CoreSyn.CoreBndr AST.VHDLName) -> func -> [arg] -> VHDLSession [AST.ConcSm]) + ((Either CoreSyn.CoreBndr AST.VHDLName) -> func -> [arg] -> TranslatorSession AST.Expr) + -> ((Either CoreSyn.CoreBndr AST.VHDLName) -> func -> [arg] -> TranslatorSession [AST.ConcSm]) genExprRes wrap dst func args = do expr <- wrap dst func args return $ [mkUncondAssign dst expr] @@ -75,22 +242,22 @@ 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' :: (AST.Expr -> AST.Expr -> AST.Expr) -> dst -> CoreSyn.CoreBndr -> [AST.Expr] -> VHDLSession AST.Expr +genOperator2 op = genNoInsts $ genExprArgs $ genExprRes (genOperator2' op) +genOperator2' :: (AST.Expr -> AST.Expr -> AST.Expr) -> dst -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession 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' :: (AST.Expr -> AST.Expr) -> dst -> CoreSyn.CoreBndr -> [AST.Expr] -> VHDLSession AST.Expr +genOperator1 op = genNoInsts $ genExprArgs $ genExprRes (genOperator1' op) +genOperator1' :: (AST.Expr -> AST.Expr) -> dst -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession AST.Expr genOperator1' op _ f [arg] = return $ op arg -- | Generate a unary operator application genNegation :: BuiltinBuilder -genNegation = genVarArgs $ genExprRes genNegation' -genNegation' :: dst -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession AST.Expr +genNegation = genNoInsts $ genVarArgs $ genExprRes genNegation' +genNegation' :: dst -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession AST.Expr genNegation' _ f [arg] = do - arg1 <- MonadState.lift vsType $ varToVHDLExpr arg + arg1 <- MonadState.lift tsType $ varToVHDLExpr arg let ty = Var.varType arg let (tycon, args) = Type.splitTyConApp ty let name = Name.getOccString (TyCon.tyConName tycon) @@ -101,19 +268,19 @@ 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' :: Bool -> Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> VHDLSession AST.Expr +genFCall switch = genNoInsts $ genExprArgs $ genExprRes (genFCall' switch) +genFCall' :: Bool -> Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession AST.Expr genFCall' switch (Left res) f args = do let fname = varToString f let el_ty = if switch then (Var.varType res) else ((tfvec_elem . Var.varType) res) - id <- MonadState.lift vsType $ vectorFunId el_ty fname + id <- MonadState.lift tsType $ vectorFunId el_ty fname return $ AST.PrimFCall $ AST.FCall (AST.NSimple id) $ map (\exp -> Nothing AST.:=>: AST.ADExpr exp) args genFCall' _ (Right name) _ _ = error $ "\nGenerate.genFCall': Cannot generate builtin function call assigned to a VHDLName: " ++ show name genFromSizedWord :: BuiltinBuilder -genFromSizedWord = genExprArgs $ genExprRes genFromSizedWord' -genFromSizedWord' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> VHDLSession AST.Expr +genFromSizedWord = genNoInsts $ genExprArgs $ genExprRes genFromSizedWord' +genFromSizedWord' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession AST.Expr genFromSizedWord' (Left res) f args = do let fname = varToString f return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId toIntegerId)) $ @@ -121,16 +288,16 @@ 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' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> VHDLSession AST.Expr +genResize = genNoInsts $ genExprArgs $ genExprRes genResize' +genResize' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession AST.Expr genResize' (Left res) f [arg] = do { ; let { ty = Var.varType res ; (tycon, args) = Type.splitTyConApp ty ; name = Name.getOccString (TyCon.tyConName tycon) } ; ; len <- case name of - "SizedInt" -> MonadState.lift vsType $ tfp_to_int (sized_int_len_ty ty) - "SizedWord" -> MonadState.lift vsType $ tfp_to_int (sized_word_len_ty ty) + "SizedInt" -> MonadState.lift tsType $ tfp_to_int (sized_int_len_ty ty) + "SizedWord" -> MonadState.lift tsType $ tfp_to_int (sized_word_len_ty ty) ; return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId resizeId)) [Nothing AST.:=>: AST.ADExpr arg, Nothing AST.:=>: AST.ADExpr( AST.PrimLit (show len))] } @@ -139,8 +306,8 @@ 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' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [Literal.Literal] -> VHDLSession AST.Expr +genFromInteger = genNoInsts $ genLitArgs $ genExprRes genFromInteger' +genFromInteger' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [Literal.Literal] -> TranslatorSession AST.Expr genFromInteger' (Left res) f lits = do { ; let { ty = Var.varType res ; (tycon, args) = Type.splitTyConApp ty @@ -150,9 +317,9 @@ genFromInteger' (Left res) f lits = do { "RangedWord" -> return $ AST.PrimLit (show (last lits)) otherwise -> do { ; len <- case name of - "SizedInt" -> MonadState.lift vsType $ tfp_to_int (sized_int_len_ty ty) - "SizedWord" -> MonadState.lift vsType $ tfp_to_int (sized_word_len_ty ty) - "RangedWord" -> MonadState.lift vsType $ tfp_to_int (ranged_word_bound_ty ty) + "SizedInt" -> MonadState.lift tsType $ tfp_to_int (sized_int_len_ty ty) + "SizedWord" -> MonadState.lift tsType $ tfp_to_int (sized_word_len_ty ty) + "RangedWord" -> MonadState.lift tsType $ tfp_to_int (ranged_word_bound_ty ty) ; let fname = case name of "SizedInt" -> toSignedId ; "SizedWord" -> toUnsignedId ; return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId fname)) [Nothing AST.:=>: AST.ADExpr (AST.PrimLit (show (last lits))), Nothing AST.:=>: AST.ADExpr( AST.PrimLit (show len))] @@ -164,6 +331,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 { @@ -174,7 +342,7 @@ genTFVec (Left res) f [Left (CoreSyn.Let (CoreSyn.Rec letBinders) letRes)] = do -- Get all the Assigned binders ; let assignedBinders = Maybe.catMaybes (map fst letAssigns) -- Make signal names for all the assigned binders - ; sigs <- mapM (\x -> MonadState.lift vsType $ varToVHDLExpr x) (assignedBinders ++ resBinders) + ; sigs <- mapM (\x -> MonadState.lift tsType $ varToVHDLExpr x) (assignedBinders ++ resBinders) -- Assign all the signals to the resulting vector ; let { vecsigns = mkAggregateSignal sigs ; vecassign = mkUncondAssign (Left res) vecsigns @@ -190,7 +358,7 @@ genTFVec (Left res) f [Left (CoreSyn.Let (CoreSyn.Rec letBinders) letRes)] = do ; return $ [AST.CSBSm block] } where - genBinderAssign :: (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -> VHDLSession (Maybe CoreSyn.CoreBndr, [AST.ConcSm]) + genBinderAssign :: (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -> TranslatorSession (Maybe CoreSyn.CoreBndr, [AST.ConcSm]) -- For now we only translate applications genBinderAssign (bndr, app@(CoreSyn.App _ _)) = do let (CoreSyn.Var f, args) = CoreSyn.collectArgs app @@ -198,7 +366,7 @@ genTFVec (Left res) f [Left (CoreSyn.Let (CoreSyn.Rec letBinders) letRes)] = do apps <- genApplication (Left bndr) f (map Left valargs) return (Just bndr, apps) genBinderAssign _ = return (Nothing,[]) - genResAssign :: CoreSyn.CoreExpr -> VHDLSession ([CoreSyn.CoreBndr], [AST.ConcSm]) + genResAssign :: CoreSyn.CoreExpr -> TranslatorSession ([CoreSyn.CoreBndr], [AST.ConcSm]) genResAssign app@(CoreSyn.App _ letexpr) = do case letexpr of (CoreSyn.Let (CoreSyn.Rec letbndrs) letres) -> do @@ -218,7 +386,7 @@ genTFVec (Left res) f [Left app@(CoreSyn.App _ _)] = do { otherwise -> error $ "\nGenerate.genTFVec: Cannot generate TFVec: " ++ show res ++ ", with elems:\n" ++ show elems ++ "\n" ++ pprString elems) elems } ; - ; sigs <- mapM (\x -> MonadState.lift vsType $ varToVHDLExpr x) binders + ; sigs <- mapM (\x -> MonadState.lift tsType $ varToVHDLExpr x) binders -- Assign all the signals to the resulting vector ; let { vecsigns = mkAggregateSignal sigs ; vecassign = mkUncondAssign (Left res) vecsigns @@ -233,7 +401,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 { @@ -242,7 +410,7 @@ genMap (Left res) f [Left mapped_f, Left (CoreSyn.Var arg)] = do { -- we must index it (which we couldn't if it was a VHDL Expr, since only -- VHDLNames can be indexed). -- Setup the generate scheme - ; len <- MonadState.lift vsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) res + ; len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) res -- TODO: Use something better than varToString ; let { label = mkVHDLExtId ("mapVector" ++ (varToString res)) ; n_id = mkVHDLBasicId "n" @@ -256,19 +424,19 @@ 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] -> TranslatorSession ([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 + ; len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) res -- TODO: Use something better than varToString ; let { label = mkVHDLExtId ("zipWithVector" ++ (varToString res)) ; n_id = mkVHDLBasicId "n" @@ -281,9 +449,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 @@ -295,20 +463,20 @@ 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] -> TranslatorSession ([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)) + len <- MonadState.lift tsType $ 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] -> TranslatorSession ([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] + arg <- MonadState.lift tsType $ varToVHDLExpr start + return ([mkUncondAssign (Left res) arg], []) genFold'' len left (Left res) f [folded_f, start, vec] = do -- The vector length - --len <- MonadState.lift vsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) vec + --len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) vec -- An expression for len-1 let len_min_expr = (AST.PrimLit $ show (len-1)) -- evec is (TFVec n), so it still needs an element type @@ -317,7 +485,7 @@ genFold'' len left (Left res) f [folded_f, start, vec] = do -- temporary vector let tmp_ty = Type.mkAppTy nvec (Var.varType start) let error_msg = "\nGenerate.genFold': Can not construct temp vector for element type: " ++ pprString tmp_ty - tmp_vhdl_ty <- MonadState.lift vsType $ vhdl_ty error_msg tmp_ty + tmp_vhdl_ty <- MonadState.lift tsType $ vhdl_ty error_msg tmp_ty -- Setup the generate scheme let gen_label = mkVHDLExtId ("foldlVector" ++ (varToString vec)) let block_label = mkVHDLExtId ("foldlVector" ++ (varToString res)) @@ -327,14 +495,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" @@ -346,9 +515,9 @@ 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 :: TranslatorSession (AST.GenerateSm, [CoreSyn.CoreBndr]) genFirstCell = do - len <- MonadState.lift vsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) vec + len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) vec let cond_label = mkVHDLExtId "firstcell" -- if n == 0 or n == len-1 let cond_scheme = AST.IfGn $ n_cur AST.:=: (if left then (AST.PrimLit "0") @@ -356,19 +525,19 @@ genFold'' len left (Left res) f [folded_f, start, vec] = do -- Output to tmp[current n] let resname = mkIndexedName tmp_name n_cur -- Input from start - argexpr1 <- MonadState.lift vsType $ varToVHDLExpr start + argexpr1 <- MonadState.lift tsType $ 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 + len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) vec let cond_label = mkVHDLExtId "othercell" -- if n > 0 or n < len-1 let cond_scheme = AST.IfGn $ n_cur AST.:/=: (if left then (AST.PrimLit "0") @@ -379,21 +548,21 @@ 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' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm] +genZip = genNoInsts $ genVarArgs genZip' +genZip' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession [AST.ConcSm] genZip' (Left res) f args@[arg1, arg2] = do { -- Setup the generate scheme - ; len <- MonadState.lift vsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) res + ; len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) res -- TODO: Use something better than varToString ; let { label = mkVHDLExtId ("zipVector" ++ (varToString res)) ; n_id = mkVHDLBasicId "n" @@ -404,7 +573,7 @@ genZip' (Left res) f args@[arg1, arg2] = do { ; argexpr1 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg1) n_expr ; argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg2) n_expr } ; - ; labels <- MonadState.lift vsType $ getFieldLabels (tfvec_elem (Var.varType res)) + ; labels <- MonadState.lift tsType $ getFieldLabels (tfvec_elem (Var.varType res)) ; let { resnameA = mkSelectedName resname' (labels!!0) ; resnameB = mkSelectedName resname' (labels!!1) ; resA_assign = mkUncondAssign (Right resnameA) argexpr1 @@ -416,11 +585,11 @@ genZip' (Left res) f args@[arg1, arg2] = do { -- | Generate a generate statement for the builtin function "unzip" genUnzip :: BuiltinBuilder -genUnzip = genVarArgs genUnzip' -genUnzip' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm] +genUnzip = genNoInsts $ genVarArgs genUnzip' +genUnzip' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession [AST.ConcSm] genUnzip' (Left res) f args@[arg] = do { -- Setup the generate scheme - ; len <- MonadState.lift vsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) arg + ; len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) arg -- TODO: Use something better than varToString ; let { label = mkVHDLExtId ("unzipVector" ++ (varToString res)) ; n_id = mkVHDLBasicId "n" @@ -430,8 +599,8 @@ genUnzip' (Left res) f args@[arg] = do { ; resname' = varToVHDLName res ; argexpr' = mkIndexedName (varToVHDLName arg) n_expr } ; - ; reslabels <- MonadState.lift vsType $ getFieldLabels (Var.varType res) - ; arglabels <- MonadState.lift vsType $ getFieldLabels (tfvec_elem (Var.varType arg)) + ; reslabels <- MonadState.lift tsType $ getFieldLabels (Var.varType res) + ; arglabels <- MonadState.lift tsType $ getFieldLabels (tfvec_elem (Var.varType arg)) ; let { resnameA = mkIndexedName (mkSelectedName resname' (reslabels!!0)) n_expr ; resnameB = mkIndexedName (mkSelectedName resname' (reslabels!!1)) n_expr ; argexprA = vhdlNameToVHDLExpr $ mkSelectedName argexpr' (arglabels!!0) @@ -444,8 +613,8 @@ genUnzip' (Left res) f args@[arg] = do { } genCopy :: BuiltinBuilder -genCopy = genVarArgs genCopy' -genCopy' :: (Either CoreSyn.CoreBndr AST.VHDLName ) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm] +genCopy = genNoInsts $ genVarArgs genCopy' +genCopy' :: (Either CoreSyn.CoreBndr AST.VHDLName ) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession [AST.ConcSm] genCopy' (Left res) f args@[arg] = let resExpr = AST.Aggregate [AST.ElemAssoc (Just AST.Others) @@ -455,13 +624,13 @@ genCopy' (Left res) f args@[arg] = return [out_assign] genConcat :: BuiltinBuilder -genConcat = genVarArgs genConcat' -genConcat' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm] +genConcat = genNoInsts $ genVarArgs genConcat' +genConcat' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession [AST.ConcSm] genConcat' (Left res) f args@[arg] = do { -- Setup the generate scheme - ; len1 <- MonadState.lift vsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) arg + ; len1 <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) arg ; let (_, nvec) = Type.splitAppTy (Var.varType arg) - ; len2 <- MonadState.lift vsType $ tfp_to_int $ tfvec_len_ty nvec + ; len2 <- MonadState.lift tsType $ tfp_to_int $ tfvec_len_ty nvec -- TODO: Use something better than varToString ; let { label = mkVHDLExtId ("concatVector" ++ (varToString res)) ; n_id = mkVHDLBasicId "n" @@ -498,18 +667,18 @@ 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] -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr]) genIterateOrGenerate' iter (Left res) f args = do - len <- MonadState.lift vsType $ tfp_to_int ((tfvec_len_ty . Var.varType) res) + len <- MonadState.lift tsType $ 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] -> TranslatorSession ([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 - -- len <- MonadState.lift vsType $ tfp_to_int ((tfvec_len_ty . Var.varType) res) + -- len <- MonadState.lift tsType $ tfp_to_int ((tfvec_len_ty . Var.varType) res) -- An expression for len-1 let len_min_expr = (AST.PrimLit $ show (len-1)) -- -- evec is (TFVec n), so it still needs an element type @@ -518,7 +687,7 @@ genIterateOrGenerate'' len iter (Left res) f [app_f, start] = do -- -- temporary vector let tmp_ty = Var.varType res let error_msg = "\nGenerate.genFold': Can not construct temp vector for element type: " ++ pprString tmp_ty - tmp_vhdl_ty <- MonadState.lift vsType $ vhdl_ty error_msg tmp_ty + tmp_vhdl_ty <- MonadState.lift tsType $ vhdl_ty error_msg tmp_ty -- Setup the generate scheme let gen_label = mkVHDLExtId ("iterateVector" ++ (varToString start)) let block_label = mkVHDLExtId ("iterateVector" ++ (varToString res)) @@ -527,12 +696,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" @@ -543,7 +713,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 :: TranslatorSession (AST.GenerateSm, [CoreSyn.CoreBndr]) genFirstCell = do let cond_label = mkVHDLExtId "firstcell" -- if n == 0 or n == len-1 @@ -551,15 +721,16 @@ genIterateOrGenerate'' len iter (Left res) f [app_f, start] = do -- Output to tmp[current n] let resname = mkIndexedName tmp_name n_cur -- Input from start - argexpr <- MonadState.lift vsType $ varToVHDLExpr start + argexpr <- MonadState.lift tsType $ 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" @@ -569,9 +740,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) ----------------------------------------------------------------------------- @@ -581,40 +752,41 @@ 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. - f' <- MonadState.lift vsType $ varToVHDLExpr f - return $ [mkUncondAssign dst f'] + 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 tsType $ varToVHDLExpr f + return $ ([mkUncondAssign dst f'], []) True -> case Var.idDetails f of IdInfo.DataConWorkId dc -> case dst of -- It's a datacon. Create a record from its arguments. Left bndr -> do -- We have the bndr, so we can get at the type - labels <- MonadState.lift vsType $ getFieldLabels (Var.varType bndr) + labels <- MonadState.lift tsType $ 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 = @@ -670,7 +842,7 @@ vectorFunId el_ty fname = do -- TODO: This should not be duplicated from mk_vector_ty. Probably but it in -- the VHDLState or something. let vectorTM = mkVHDLExtId $ "vector_" ++ (AST.fromVHDLId elemTM) - typefuns <- getA vsTypeFuns + typefuns <- getA tsTypeFuns case Map.lookup (OrdType el_ty, fname) typefuns of -- Function already generated, just return it Just (id, _) -> return id @@ -679,7 +851,7 @@ vectorFunId el_ty fname = do let functions = genUnconsVectorFuns elemTM vectorTM case lookup fname functions of Just body -> do - modA vsTypeFuns $ Map.insert (OrdType el_ty, fname) (function_id, (fst body)) + modA tsTypeFuns $ Map.insert (OrdType el_ty, fname) (function_id, (fst body)) mapM_ (vectorFunId el_ty) (snd body) return function_id Nothing -> error $ "\nGenerate.vectorFunId: I don't know how to generate vector function " ++ fname @@ -1060,6 +1232,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 @@ -1110,6 +1295,6 @@ globalNameTable = Map.fromList , (fromIntegerId , (1, genFromInteger ) ) , (resizeId , (1, genResize ) ) , (sizedIntId , (1, genSizedInt ) ) - , (tfvecId , (1, genTFVec ) ) + --, (tfvecId , (1, genTFVec ) ) , (minimumId , (2, error $ "\nFunction name: \"minimum\" is used internally, use another name")) ] diff --git "a/c\316\273ash/CLasH/VHDL/Testbench.hs" "b/c\316\273ash/CLasH/VHDL/Testbench.hs" new file mode 100644 index 0000000..76fc073 --- /dev/null +++ "b/c\316\273ash/CLasH/VHDL/Testbench.hs" @@ -0,0 +1,161 @@ +-- +-- Functions to create a VHDL testbench from a list of test input. +-- +module CLasH.VHDL.Testbench where + +-- Standard modules +import qualified Control.Monad as Monad +import qualified Maybe +import qualified Data.Map as Map +import Data.Accessor +import qualified Data.Accessor.MonadState as MonadState + +-- ForSyDe +import qualified Language.VHDL.AST as AST + +-- GHC API +import CoreSyn +import qualified Var +import qualified TysWiredIn + +-- Local imports +import CLasH.Translator.TranslatorTypes +import CLasH.VHDL.Constants +import CLasH.VHDL.Generate +import CLasH.VHDL.VHDLTools +import CLasH.VHDL.VHDLTypes +import CLasH.Normalize +import CLasH.Utils.Core.BinderTools +import CLasH.Utils.Core.CoreTools +import CLasH.Utils + +createTestbench :: + Maybe Int -- ^ Number of cycles to simulate + -> CoreSyn.CoreExpr -- ^ Input stimuli + -> CoreSyn.CoreBndr -- ^ Top Entity + -> TranslatorSession CoreBndr -- ^ The id of the generated archictecture +createTestbench mCycles stimuli top = do + let stimuli' = reduceCoreListToHsList stimuli + -- Create a binder for the testbench. We use the unit type (), since the + -- testbench has no outputs and no inputs. + bndr <- mkInternalVar "testbench" TysWiredIn.unitTy + let entity = createTestbenchEntity bndr + modA tsEntities (Map.insert bndr entity) + arch <- createTestbenchArch mCycles stimuli' top entity + modA tsArchitectures (Map.insert bndr arch) + return bndr + +createTestbenchEntity :: + CoreSyn.CoreBndr + -> Entity +createTestbenchEntity bndr = entity + where + vhdl_id = mkVHDLBasicId $ varToString bndr + -- Create an AST entity declaration with no ports + ent_decl = AST.EntityDec vhdl_id [] + -- Create a signature with no input and no output ports + entity = Entity vhdl_id [] undefined ent_decl + +createTestbenchArch :: + Maybe Int -- ^ Number of cycles to simulate + -> [CoreSyn.CoreExpr] -- ^ Imput stimuli + -> CoreSyn.CoreBndr -- ^ Top Entity + -> Entity -- ^ The signature to create an architecture for + -> TranslatorSession (Architecture, [CoreSyn.CoreBndr]) + -- ^ The architecture and any other entities used. +createTestbenchArch mCycles stimuli top testent= do + signature <- getEntity top + let entId = ent_id signature + iIface = ent_args signature + oIface = ent_res signature + iIds = map fst iIface + oId = fst oIface + let iDecs = map (\(vId, tm) -> AST.SigDec vId tm Nothing) iIface + let finalIDecs = iDecs ++ + [AST.SigDec clockId std_logicTM (Just $ AST.PrimLit "'0'"), + AST.SigDec resetId std_logicTM (Just $ AST.PrimLit "'0'")] + let oDecs = AST.SigDec (fst oIface) (snd oIface) Nothing + let portmaps = mkAssocElems (map idToVHDLExpr iIds) (AST.NSimple oId) signature + let mIns = mkComponentInst "totest" entId portmaps + (stimuliAssigns, stimuliDecs, cycles, used) <- createStimuliAssigns mCycles stimuli (head iIds) + let finalAssigns = (AST.CSSASm (AST.NSimple resetId AST.:<==: + AST.ConWforms [] + (AST.Wform [AST.WformElem (AST.PrimLit "'1'") (Just $ AST.PrimLit "3 ns")]) + Nothing)) : stimuliAssigns + let clkProc = createClkProc + let outputProc = createOutputProc [oId] + let arch = AST.ArchBody + (AST.unsafeVHDLBasicId "test") + (AST.NSimple $ ent_id testent) + (map AST.BDISD (finalIDecs ++ stimuliDecs ++ [oDecs])) + (mIns : + ( (AST.CSPSm clkProc) : (AST.CSPSm outputProc) : finalAssigns ) ) + return (arch, top : used) + +createStimuliAssigns :: + Maybe Int -- ^ Number of cycles to simulate + -> [CoreSyn.CoreExpr] -- ^ Input stimuli + -> AST.VHDLId -- ^ Input signal + -> TranslatorSession ( [AST.ConcSm] -- ^ Resulting statemetns + , [AST.SigDec] -- ^ Needed signals + , Int -- ^ The number of cycles to simulate + , [CoreSyn.CoreBndr]) -- ^ Any entities used +createStimuliAssigns mCycles [] _ = return ([], [], Maybe.maybe 0 id mCycles, []) + +createStimuliAssigns mCycles stimuli signal = do + let genWformElem time stim = (AST.WformElem stim (Just $ AST.PrimLit (show time ++ " ns"))) + let inputlen = length stimuli + assigns <- Monad.zipWithM createStimulans stimuli [0..inputlen] + let (stimuli_sms, resvars, useds) = unzip3 assigns + sig_dec_maybes <- mapM mkSigDec resvars + let sig_decs = Maybe.catMaybes sig_dec_maybes + outps <- mapM (\x -> MonadState.lift tsType (varToVHDLExpr x)) resvars + let wformelems = zipWith genWformElem [0,10..] outps + let inassign = AST.CSSASm $ AST.NSimple signal AST.:<==: AST.ConWforms [] (AST.Wform wformelems) Nothing + return (stimuli_sms ++ [inassign], sig_decs, inputlen, concat useds) + +createStimulans :: + CoreSyn.CoreExpr -- ^ The stimulans + -> Int -- ^ The cycle for this stimulans + -> TranslatorSession ( AST.ConcSm -- ^ The statement + , Var.Var -- ^ the variable it assigns to (assumed to be available!) + , [CoreSyn.CoreBndr]) -- ^ Any entities used by this stimulans + +createStimulans expr cycl = do + -- There must be a let at top level + (CoreSyn.Let (CoreSyn.Rec binds) (Var res)) <- normalizeExpr ("test input #" ++ show cycl) expr + (stimulansbindss, useds) <- unzipM $ Monad.mapM mkConcSm binds + sig_dec_maybes <- mapM (mkSigDec . fst) (filter ((/=res).fst) binds) + let sig_decs = map (AST.BDISD) (Maybe.catMaybes $ sig_dec_maybes) + let block_label = mkVHDLExtId ("testcycle_" ++ (show cycl)) + let block = AST.BlockSm block_label [] (AST.PMapAspect []) sig_decs (concat stimulansbindss) + return (AST.CSBSm block, res, concat useds) + +-- | generates a clock process with a period of 10ns +createClkProc :: AST.ProcSm +createClkProc = AST.ProcSm (AST.unsafeVHDLBasicId "clkproc") [] sms + where sms = -- wait for 5 ns -- (half a cycle) + [AST.WaitFor $ AST.PrimLit "5 ns", + -- clk <= not clk; + AST.NSimple clockId `AST.SigAssign` + AST.Wform [AST.WformElem (AST.Not (AST.PrimName $ AST.NSimple clockId)) Nothing]] + +-- | generate the output process +createOutputProc :: [AST.VHDLId] -- ^ output signal + -> AST.ProcSm +createOutputProc outs = + AST.ProcSm (AST.unsafeVHDLBasicId "writeoutput") + [clockId] + [AST.IfSm clkPred (writeOuts outs) [] Nothing] + where clkPred = AST.PrimName (AST.NAttribute $ AST.AttribName (AST.NSimple clockId) + (AST.NSimple $ eventId) + Nothing ) `AST.And` + (AST.PrimName (AST.NSimple clockId) AST.:=: AST.PrimLit "'1'") + writeOuts :: [AST.VHDLId] -> [AST.SeqSm] + writeOuts [] = [] + writeOuts [i] = [writeOut i (AST.PrimLit "LF")] + writeOuts (i:is) = writeOut i (AST.PrimLit "HT") : writeOuts is + writeOut outSig suffix = + genExprPCall2 writeId + (AST.PrimName $ AST.NSimple outputId) + ((genExprFCall showId (AST.PrimName $ AST.NSimple outSig)) AST.:&: suffix) diff --git "a/c\316\273ash/CLasH/VHDL/VHDLTools.hs" "b/c\316\273ash/CLasH/VHDL/VHDLTools.hs" index 9c10afd..fbe33a7 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 @@ -281,7 +282,7 @@ vhdl_ty msg ty = do -- Returns either an error message or the resulting type. vhdl_ty_either :: Type.Type -> TypeSession (Either String AST.TypeMark) vhdl_ty_either ty = do - typemap <- getA vsTypes + typemap <- getA tsTypes htype_either <- mkHType ty case htype_either of -- No errors @@ -301,8 +302,8 @@ vhdl_ty_either ty = do case newty_maybe of Right (ty_id, ty_def) -> do -- TODO: Check name uniqueness - modA vsTypes (Map.insert htype (ty_id, ty_def)) - modA vsTypeDecls (\typedefs -> typedefs ++ [mktydecl (ty_id, ty_def)]) + modA tsTypes (Map.insert htype (ty_id, ty_def)) + modA tsTypeDecls (\typedefs -> typedefs ++ [mktydecl (ty_id, ty_def)]) return (Right ty_id) Left err -> return $ Left $ "VHDLTools.vhdl_ty: Unsupported Haskell type: " ++ pprString ty ++ "\n" @@ -353,7 +354,7 @@ mk_tycon_ty ty tycon args = let ty_id = mkVHDLExtId $ nameToString (TyCon.tyConName tycon) ++ elem_names let ty_def = AST.TDR $ AST.RecordTypeDef elems let tupshow = mkTupleShow elem_tys ty_id - modA vsTypeFuns $ Map.insert (OrdType ty, showIdString) (showId, tupshow) + modA tsTypeFuns $ Map.insert (OrdType ty, showIdString) (showId, tupshow) return $ Right (ty_id, Left ty_def) -- There were errors in element types (errors, _) -> return $ Left $ @@ -376,8 +377,8 @@ mk_vector_ty :: -- ^ An error message or The typemark created. mk_vector_ty ty = do - types_map <- getA vsTypes - env <- getA vsHscEnv + types_map <- getA tsTypes + env <- getA tsHscEnv let (nvec_l, nvec_el) = Type.splitAppTy ty let (nvec, leng) = Type.splitAppTy nvec_l let vec_ty = Type.mkAppTy nvec nvec_el @@ -397,10 +398,10 @@ mk_vector_ty ty = do Nothing -> do let vec_id = mkVHDLExtId $ "vector_" ++ (AST.fromVHDLId el_ty_tm) let vec_def = AST.TDA $ AST.UnconsArrayDef [tfvec_indexTM] el_ty_tm - modA vsTypes (Map.insert (StdType $ OrdType vec_ty) (vec_id, (Left vec_def))) - modA vsTypeDecls (\typedefs -> typedefs ++ [mktydecl (vec_id, (Left vec_def))]) + modA tsTypes (Map.insert (StdType $ OrdType vec_ty) (vec_id, (Left vec_def))) + modA tsTypeDecls (\typedefs -> typedefs ++ [mktydecl (vec_id, (Left vec_def))]) let vecShowFuns = mkVectorShow el_ty_tm vec_id - mapM_ (\(id, subprog) -> modA vsTypeFuns $ Map.insert (OrdType vec_ty, id) ((mkVHDLExtId id), subprog)) vecShowFuns + mapM_ (\(id, subprog) -> modA tsTypeFuns $ Map.insert (OrdType vec_ty, id) ((mkVHDLExtId id), subprog)) vecShowFuns let ty_def = AST.SubtypeIn vec_id (Just range) return (Right (ty_id, Right ty_def)) -- Could not create element type @@ -428,7 +429,7 @@ mk_unsigned_ty ty = do let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (size - 1))] let ty_def = AST.SubtypeIn unsignedTM (Just range) let unsignedshow = mkIntegerShow ty_id - modA vsTypeFuns $ Map.insert (OrdType ty, showIdString) (showId, unsignedshow) + modA tsTypeFuns $ Map.insert (OrdType ty, showIdString) (showId, unsignedshow) return (Right (ty_id, Right ty_def)) mk_signed_ty :: @@ -440,7 +441,7 @@ mk_signed_ty ty = do let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (size - 1))] let ty_def = AST.SubtypeIn signedTM (Just range) let signedshow = mkIntegerShow ty_id - modA vsTypeFuns $ Map.insert (OrdType ty, showIdString) (showId, signedshow) + modA tsTypeFuns $ Map.insert (OrdType ty, showIdString) (showId, signedshow) return (Right (ty_id, Right ty_def)) -- Finds the field labels for VHDL type generated for the given Core type, @@ -451,7 +452,7 @@ getFieldLabels ty = do let error_msg = "\nVHDLTools.getFieldLabels: Can not get field labels, because: " ++ pprString ty ++ "can not be generated." vhdl_ty error_msg ty -- Get the types map, lookup and unpack the VHDL TypeDef - types <- getA vsTypes + types <- getA tsTypes -- Assume the type for which we want labels is really translatable Right htype <- mkHType ty case Map.lookup htype types of @@ -536,7 +537,7 @@ isReprType ty = do tfp_to_int :: Type.Type -> TypeSession Int tfp_to_int ty = do - hscenv <- getA vsHscEnv + hscenv <- getA tsHscEnv let norm_ty = normalise_tfp_int hscenv ty case Type.splitTyConApp_maybe norm_ty of Just (tycon, args) -> do @@ -546,21 +547,21 @@ tfp_to_int ty = do len <- tfp_to_int' ty return len otherwise -> do - modA vsTfpInts (Map.insert (OrdType norm_ty) (-1)) + modA tsTfpInts (Map.insert (OrdType norm_ty) (-1)) return $ error ("Callin tfp_to_int on non-dec:" ++ (show ty)) Nothing -> return $ error ("Callin tfp_to_int on non-dec:" ++ (show ty)) tfp_to_int' :: Type.Type -> TypeSession Int tfp_to_int' ty = do - lens <- getA vsTfpInts - hscenv <- getA vsHscEnv + lens <- getA tsTfpInts + hscenv <- getA tsHscEnv let norm_ty = normalise_tfp_int hscenv ty let existing_len = Map.lookup (OrdType norm_ty) lens case existing_len of Just len -> return len Nothing -> do let new_len = eval_tfp_int hscenv ty - modA vsTfpInts (Map.insert (OrdType norm_ty) (new_len)) + modA tsTfpInts (Map.insert (OrdType norm_ty) (new_len)) return new_len mkTupleShow :: @@ -697,11 +698,11 @@ genExprPCall2 entid arg1 arg2 = AST.ProcCall (AST.NSimple entid) $ map (\exp -> Nothing AST.:=>: AST.ADExpr exp) [arg1,arg2] -mkSigDec :: CoreSyn.CoreBndr -> VHDLSession (Maybe AST.SigDec) +mkSigDec :: CoreSyn.CoreBndr -> TranslatorSession (Maybe AST.SigDec) mkSigDec bndr = if True then do --isInternalSigUse use || isStateSigUse use then do let error_msg = "\nVHDL.mkSigDec: Can not make signal declaration for type: \n" ++ pprString bndr - type_mark <- MonadState.lift vsType $ vhdl_ty error_msg (Var.varType bndr) + type_mark <- MonadState.lift tsType $ vhdl_ty error_msg (Var.varType bndr) return $ Just (AST.SigDec (varToVHDLId bndr) type_mark Nothing) else return Nothing 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: