From: Christiaan Baaij Date: Tue, 28 Jul 2009 14:52:18 +0000 (+0200) Subject: Add automated testbench generation according to supplied test input X-Git-Url: https://git.stderr.nl/gitweb?p=matthijs%2Fmaster-project%2Fc%CE%BBash.git;a=commitdiff_plain;h=4c63601269c7097e2177c547dc36d4edecc1c648 Add automated testbench generation according to supplied test input Will not compile in VHDL yet as we need to implement the VHDL show method first --- diff --git a/HighOrdAlu.hs b/HighOrdAlu.hs index eb92520..1ead210 100644 --- a/HighOrdAlu.hs +++ b/HighOrdAlu.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE TemplateHaskell #-} + module HighOrdAlu where import Prelude hiding ( @@ -33,6 +35,11 @@ xhwor = hwor type Op n e = (TFVec n e -> TFVec n e -> TFVec n e) type Opcode = Bit +{-# ANN sim_input TestInput#-} +sim_input = [ (High,$(vectorTH [High,Low,Low,Low]),$(vectorTH [High,Low,Low,Low])) + , (High,$(vectorTH [High,High,High,High]),$(vectorTH [High,High,High,High])) + , (Low,$(vectorTH [High,Low,Low,High]),$(vectorTH [High,Low,High,Low]))] + {-# ANN actual_alu InitState #-} initstate = High @@ -43,6 +50,6 @@ alu op1 op2 opc a b = High -> op2 a b {-# ANN actual_alu TopEntity #-} -actual_alu :: Opcode -> TFVec D4 Bit -> TFVec D4 Bit -> TFVec D4 Bit +actual_alu :: (Opcode, TFVec D4 Bit, TFVec D4 Bit) -> TFVec D4 Bit --actual_alu = alu (constant Low) andop -actual_alu = alu (anyset xhwor) andop +actual_alu (opc, a, b) = alu (anyset xhwor) (andop) opc a b diff --git "a/c\316\273ash-nolibdir/clash-nolibdir.cabal" "b/c\316\273ash-nolibdir/clash-nolibdir.cabal" index a58db53..7ed0838 100644 --- "a/c\316\273ash-nolibdir/clash-nolibdir.cabal" +++ "b/c\316\273ash-nolibdir/clash-nolibdir.cabal" @@ -1,8 +1,8 @@ name: clash-nolibdir version: 0.1 build-type: Simple -synopsis: CAES Languege for Hardware Descriptions (CλasH) -description: CλasH is a toolchain/language to translate subsets of +synopsis: CAES Languege for Hardware Descriptions (CLasH) +description: CLasH is a toolchain/language to translate subsets of Haskell to synthesizable VHDL. It does this by translating the intermediate System Fc (GHC Core) representation to a VHDL AST, which is then written to file. @@ -20,4 +20,4 @@ Library build-depends: base > 4, clash, ghc-paths extensions: PackageImports exposed-modules: CLasH.Translator - \ No newline at end of file + diff --git "a/c\316\273ash/CLasH/Normalize.hs" "b/c\316\273ash/CLasH/Normalize.hs" index 7224610..6096c65 100644 --- "a/c\316\273ash/CLasH/Normalize.hs" +++ "b/c\316\273ash/CLasH/Normalize.hs" @@ -467,22 +467,28 @@ 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)], TypeState) -- ^ The resulting VHDL + -> ([(CoreBndr, CoreExpr)], [(CoreBndr, CoreExpr)], TypeState) -- ^ The resulting VHDL -normalizeModule env uniqsupply bindings generate_for statefuls = runTransformSession env uniqsupply $ do +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) + putA tsBindings (Map.fromList (bindings ++ testbinds)) -- (Recursively) normalize each of the requested bindings - mapM normalizeBind generate_for + 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_bindings <- getA tsNormalized + 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 $ (filter ((flip VarSet.elemVarSet normalized_bindings) . fst) bindings, typestate) + return $ (ret_binds, ret_testbinds, typestate) normalizeBind :: CoreBndr -> TransformSession () normalizeBind bndr = diff --git "a/c\316\273ash/CLasH/Normalize/NormalizeTools.hs" "b/c\316\273ash/CLasH/Normalize/NormalizeTools.hs" index e1b8727..7f575ad 100644 --- "a/c\316\273ash/CLasH/Normalize/NormalizeTools.hs" +++ "b/c\316\273ash/CLasH/Normalize/NormalizeTools.hs" @@ -44,8 +44,11 @@ import qualified CLasH.VHDL.VHDLTools as VHDLTools -- 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 = do - uniq <- mkUnique +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 @@ -55,8 +58,11 @@ mkInternalVar str ty = do -- 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 = do - uniq <- mkUnique +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 @@ -65,8 +71,11 @@ mkTypeVar str kind = do -- 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 (Type ty) string = mkTypeVar string (Type.typeKind ty) -mkBinderFor expr string = mkInternalVar string (CoreUtils.exprType expr) +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 @@ -221,11 +230,14 @@ change val = do -- Create a new Unique mkUnique :: TransformMonad Unique.Unique -mkUnique = Trans.lift $ do - us <- getA tsUniqSupply - let (us', us'') = UniqSupply.splitUniqSupply us - putA tsUniqSupply us' - return $ UniqSupply.uniqFromSupply us'' +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. diff --git "a/c\316\273ash/CLasH/Translator.hs" "b/c\316\273ash/CLasH/Translator.hs" index c1e853a..c35e338 100644 --- "a/c\316\273ash/CLasH/Translator.hs" +++ "b/c\316\273ash/CLasH/Translator.hs" @@ -53,27 +53,29 @@ import CLasH.Translator.Annotations import CLasH.Utils.Pretty import CLasH.Normalize import CLasH.VHDL.VHDLTypes +import CLasH.Utils.Core.CoreTools import qualified CLasH.VHDL as VHDL -makeVHDL :: FilePath -> String -> String -> Bool -> IO () -makeVHDL libdir filename name stateful = do - -- Load the module - (core, env) <- loadModule libdir filename - -- Translate to VHDL - vhdl <- moduleToVHDL env core [(name, stateful)] - -- Write VHDL to file - let dir = "./vhdl/" ++ name ++ "/" - prepareDir dir - mapM (writeVHDL dir) vhdl - return () +-- makeVHDL :: FilePath -> String -> String -> Bool -> IO () +-- makeVHDL libdir filename name stateful = do +-- -- Load the module +-- (core, env) <- loadModule libdir filename +-- -- Translate to VHDL +-- vhdl <- moduleToVHDL env core [(name, stateful)] +-- -- Write VHDL to file +-- let dir = "./vhdl/" ++ name ++ "/" +-- prepareDir dir +-- mapM (writeVHDL dir) vhdl +-- return () makeVHDLAnn :: FilePath -> String -> IO () makeVHDLAnn libdir filename = do - (core, top, init, env) <- loadModuleAnn libdir filename + (core, top, init, test, env) <- loadModuleAnn libdir filename let top_entity = head top + let test_expr = head test vhdl <- case init of - [] -> moduleToVHDLAnn env core [top_entity] - xs -> moduleToVHDLAnnState env core [(top_entity, (head xs))] + [] -> moduleToVHDLAnn env core (top_entity, test_expr) + xs -> moduleToVHDLAnnState env core (top_entity, test_expr, (head xs)) let dir = "./vhdl/" ++ (show top_entity) ++ "/" prepareDir dir mapM (writeVHDL dir) vhdl @@ -108,31 +110,31 @@ listBind libdir filename name = do putStr $ showSDoc $ ppr expr putStr "\n\n" putStr $ showSDoc $ ppr $ CoreUtils.exprType expr - putStr "\n\n" + putStr "\n\n" -- | Translate the binds with the given names from the given core module to -- VHDL. The Bool in the tuple makes the function stateful (True) or -- stateless (False). -moduleToVHDL :: HscTypes.HscEnv -> HscTypes.CoreModule -> [(String, Bool)] -> IO [(AST.VHDLId, AST.DesignFile)] -moduleToVHDL env core list = do - let (names, statefuls) = unzip list - let binds = map fst $ findBinds core names - -- 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' - -- Turn bind into VHDL - let all_bindings = (CoreSyn.flattenBinds $ cm_binds core) - let (normalized_bindings, typestate) = normalizeModule env uniqSupply all_bindings binds statefuls - let vhdl = VHDL.createDesignFiles typestate normalized_bindings - mapM (putStr . render . Ppr.ppr . snd) vhdl - --putStr $ "\n\nFinal session:\n" ++ prettyShow sess ++ "\n\n" - return vhdl +-- moduleToVHDL :: HscTypes.HscEnv -> HscTypes.CoreModule -> [(String, Bool)] -> IO [(AST.VHDLId, AST.DesignFile)] +-- moduleToVHDL env core list = do +-- let (names, statefuls) = unzip list +-- let binds = map fst $ findBinds core names +-- -- 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' +-- -- Turn bind into VHDL +-- let all_bindings = (CoreSyn.flattenBinds $ cm_binds core) +-- let (normalized_bindings, typestate) = normalizeModule env uniqSupply all_bindings binds statefuls +-- let vhdl = VHDL.createDesignFiles typestate normalized_bindings binds +-- mapM (putStr . render . Ppr.ppr . snd) vhdl +-- --putStr $ "\n\nFinal session:\n" ++ prettyShow sess ++ "\n\n" +-- return vhdl -moduleToVHDLAnn :: HscTypes.HscEnv -> HscTypes.CoreModule -> [CoreSyn.CoreBndr] -> IO [(AST.VHDLId, AST.DesignFile)] -moduleToVHDLAnn env core binds = do +moduleToVHDLAnn :: HscTypes.HscEnv -> HscTypes.CoreModule -> (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -> IO [(AST.VHDLId, AST.DesignFile)] +moduleToVHDLAnn env core (topbind, test) = do -- Generate a UniqSupply -- Running -- egrep -r "(initTcRnIf|mkSplitUniqSupply)" . @@ -141,15 +143,15 @@ moduleToVHDLAnn env core binds = do uniqSupply <- UniqSupply.mkSplitUniqSupply 'z' -- Turn bind into VHDL let all_bindings = (CoreSyn.flattenBinds $ cm_binds core) - let (normalized_bindings, typestate) = normalizeModule env uniqSupply all_bindings binds [False] - let vhdl = VHDL.createDesignFiles typestate normalized_bindings + let testexprs = reduceCoreListToHsList test + let (normalized_bindings, test_bindings, typestate) = normalizeModule env uniqSupply all_bindings testexprs [topbind] [False] + let vhdl = VHDL.createDesignFiles typestate normalized_bindings topbind test_bindings mapM (putStr . render . Ppr.ppr . snd) vhdl --putStr $ "\n\nFinal session:\n" ++ prettyShow sess ++ "\n\n" return vhdl -moduleToVHDLAnnState :: HscTypes.HscEnv -> HscTypes.CoreModule -> [(CoreSyn.CoreBndr, CoreSyn.CoreBndr)] -> IO [(AST.VHDLId, AST.DesignFile)] -moduleToVHDLAnnState env core list = do - let (binds, init_states) = unzip list +moduleToVHDLAnnState :: HscTypes.HscEnv -> HscTypes.CoreModule -> (CoreSyn.CoreBndr, CoreSyn.CoreExpr, CoreSyn.CoreBndr) -> IO [(AST.VHDLId, AST.DesignFile)] +moduleToVHDLAnnState env core (topbind, test, init_state) = do -- Generate a UniqSupply -- Running -- egrep -r "(initTcRnIf|mkSplitUniqSupply)" . @@ -158,8 +160,9 @@ moduleToVHDLAnnState env core list = do uniqSupply <- UniqSupply.mkSplitUniqSupply 'z' -- Turn bind into VHDL let all_bindings = (CoreSyn.flattenBinds $ cm_binds core) - let (normalized_bindings, typestate) = normalizeModule env uniqSupply all_bindings binds [True] - let vhdl = VHDL.createDesignFiles typestate normalized_bindings + let testexprs = reduceCoreListToHsList test + let (normalized_bindings, test_bindings, typestate) = normalizeModule env uniqSupply all_bindings testexprs [topbind] [True] + let vhdl = VHDL.createDesignFiles typestate normalized_bindings topbind test_bindings mapM (putStr . render . Ppr.ppr . snd) vhdl --putStr $ "\n\nFinal session:\n" ++ prettyShow sess ++ "\n\n" return vhdl @@ -206,7 +209,7 @@ loadModule libdir filename = return (core, env) -- | Loads the given file and turns it into a core module. -loadModuleAnn :: FilePath -> String -> IO (HscTypes.CoreModule, [CoreSyn.CoreBndr], [CoreSyn.CoreBndr], HscTypes.HscEnv) +loadModuleAnn :: FilePath -> String -> IO (HscTypes.CoreModule, [CoreSyn.CoreBndr], [CoreSyn.CoreBndr], [CoreSyn.CoreExpr], HscTypes.HscEnv) loadModuleAnn libdir filename = defaultErrorHandler defaultDynFlags $ do runGhc (Just libdir) $ do @@ -222,7 +225,8 @@ loadModuleAnn libdir filename = env <- GHC.getSession top_entity <- findTopEntity core init_state <- findInitState core - return (core, top_entity, init_state, env) + test_input <- findTestInput core + return (core, top_entity, init_state, test_input, env) findTopEntity :: GhcMonad m => HscTypes.CoreModule -> m [CoreSyn.CoreBndr] findTopEntity core = do @@ -238,6 +242,13 @@ findInitState core = do let bndrs = case statebinds of [] -> [] ; xs -> fst (unzip statebinds) return bndrs +findTestInput :: GhcMonad m => HscTypes.CoreModule -> m [CoreSyn.CoreExpr] +findTestInput core = do + let binds = CoreSyn.flattenBinds $ cm_binds core + testbinds <- Monad.filterM (hasTestInputAnnotation . fst) binds + let exprs = case testbinds of [] -> [] ; xs -> snd (unzip testbinds) + return exprs + hasTopEntityAnnotation :: GhcMonad m => Var.Var -> m Bool hasTopEntityAnnotation var = do let deserializer = Serialized.deserializeWithData @@ -257,6 +268,16 @@ hasInitStateAnnotation var = do case top_ents of [] -> return False xs -> return True + +hasTestInputAnnotation :: GhcMonad m => Var.Var -> m Bool +hasTestInputAnnotation var = do + let deserializer = Serialized.deserializeWithData + let target = Annotations.NamedTarget (Var.varName var) + (anns :: [CLasHAnn]) <- GHC.findGlobalAnns deserializer target + let top_ents = filter isTestInput anns + case top_ents of + [] -> return False + xs -> return True -- | Extracts the named binds from the given module. findBinds :: HscTypes.CoreModule -> [String] -> [(CoreBndr, CoreExpr)] diff --git "a/c\316\273ash/CLasH/Translator/Annotations.hs" "b/c\316\273ash/CLasH/Translator/Annotations.hs" index 08e7845..ff2bb4b 100644 --- "a/c\316\273ash/CLasH/Translator/Annotations.hs" +++ "b/c\316\273ash/CLasH/Translator/Annotations.hs" @@ -4,7 +4,7 @@ module CLasH.Translator.Annotations where import Language.Haskell.TH import Data.Data -data CLasHAnn = TopEntity | InitState +data CLasHAnn = TopEntity | InitState | TestInput | TestCycles deriving (Show, Data, Typeable) isTopEntity :: CLasHAnn -> Bool @@ -13,4 +13,12 @@ isTopEntity _ = False isInitState :: CLasHAnn -> Bool isInitState InitState = True -isInitState _ = False \ No newline at end of file +isInitState _ = False + +isTestInput :: CLasHAnn -> Bool +isTestInput TestInput = True +isTestInput _ = False + +isTestCycles :: CLasHAnn -> Bool +isTestCycles TestCycles = True +isTestCycles _ = False \ No newline at end of file diff --git "a/c\316\273ash/CLasH/Utils/Core/CoreTools.hs" "b/c\316\273ash/CLasH/Utils/Core/CoreTools.hs" index e0a5c11..42373a4 100644 --- "a/c\316\273ash/CLasH/Utils/Core/CoreTools.hs" +++ "b/c\316\273ash/CLasH/Utils/Core/CoreTools.hs" @@ -211,3 +211,14 @@ getLiterals app@(CoreSyn.App _ _) = literals where (CoreSyn.Var f, args) = CoreSyn.collectArgs app literals = filter (is_lit) args + +-- reduceCoreListToHsList :: CoreExpr -> [a] +reduceCoreListToHsList app@(CoreSyn.App _ _) = out + where + (fun, args) = CoreSyn.collectArgs app + len = length args + out = case len of + 3 -> ((args!!1) : (reduceCoreListToHsList (args!!2))) + otherwise -> [] + +reduceCoreListToHsList _ = [] diff --git "a/c\316\273ash/CLasH/VHDL.hs" "b/c\316\273ash/CLasH/VHDL.hs" index 031acc8..21452a9 100644 --- "a/c\316\273ash/CLasH/VHDL.hs" +++ "b/c\316\273ash/CLasH/VHDL.hs" @@ -38,20 +38,25 @@ import CLasH.Utils.Pretty import CLasH.Utils.Core.CoreTools import CLasH.VHDL.Constants import CLasH.VHDL.Generate +-- import CLasH.VHDL.Testbench createDesignFiles :: TypeState -> [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)] + -> CoreSyn.CoreBndr -- ^ Top binder + -> [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)] -- ^ Test Input -> [(AST.VHDLId, AST.DesignFile)] -createDesignFiles init_typestate binds = +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 + map (Arrow.second $ AST.DesignFile full_context) (units ++ [testbench]) where init_session = VHDLState init_typestate Map.empty - (units, final_session) = + (units, final_session') = State.runState (createLibraryUnits binds) init_session + (testbench, final_session) = + State.runState (createTestBench Nothing testinput topbind) final_session' tyfun_decls = map snd $ Map.elems (final_session ^. vsType ^. vsTypeFuns) ty_decls = final_session ^. vsType ^. vsTypeDecls tfvec_index_decl = AST.PDISD $ AST.SubtypeDec tfvec_indexTM tfvec_index_def @@ -60,7 +65,8 @@ createDesignFiles init_typestate binds = ieee_context = [ AST.Library $ mkVHDLBasicId "IEEE", mkUseAll ["IEEE", "std_logic_1164"], - mkUseAll ["IEEE", "numeric_std"] + mkUseAll ["IEEE", "numeric_std"], + mkUseAll ["std", "textio"] ] full_context = mkUseAll ["work", "types"] @@ -296,3 +302,127 @@ mkConcSm (bndr, (Case (Var scrut) b ty [(_, _, Var false), (con, _, Var true)])) 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) + 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 = + genExprFCall2 writeId + (AST.PrimName $ AST.NSimple outputId) + (genExprFCall1 showId ((AST.PrimName $ AST.NSimple outSig) AST.:&: suffix)) + genExprFCall2 entid arg1 arg2 = + AST.ProcCall (AST.NSimple entid) $ + map (\exp -> Nothing AST.:=>: AST.ADExpr exp) [arg1,arg2] + genExprFCall1 entid arg = + AST.PrimFCall $ AST.FCall (AST.NSimple entid) $ + map (\exp -> Nothing AST.:=>: AST.ADExpr exp) [arg] diff --git "a/c\316\273ash/CLasH/VHDL/Constants.hs" "b/c\316\273ash/CLasH/VHDL/Constants.hs" index 317cb64..f465d84 100644 --- "a/c\316\273ash/CLasH/VHDL/Constants.hs" +++ "b/c\316\273ash/CLasH/VHDL/Constants.hs" @@ -261,6 +261,21 @@ toUnsignedId = "to_unsigned" resizeId :: String resizeId = "resize" +-- | output file identifier (from std.textio) +showIdString :: String +showIdString = "show" + +showId :: AST.VHDLId +showId = AST.unsafeVHDLBasicId showIdString + +-- | write function identifier (from std.textio) +writeId :: AST.VHDLId +writeId = AST.unsafeVHDLBasicId "write" + +-- | output file identifier (from std.textio) +outputId :: AST.VHDLId +outputId = AST.unsafeVHDLBasicId "output" + ------------------ -- VHDL type marks ------------------ diff --git "a/c\316\273ash/clash.cabal" "b/c\316\273ash/clash.cabal" index 69fd79f..24cf850 100644 --- "a/c\316\273ash/clash.cabal" +++ "b/c\316\273ash/clash.cabal" @@ -1,8 +1,8 @@ name: clash version: 0.1 build-type: Simple -synopsis: CAES Languege for Hardware Descriptions (CλasH) -description: CλasH is a toolchain/language to translate subsets of +synopsis: CAES Languege for Hardware Descriptions (CLasH) +description: CLasH is a toolchain/language to translate subsets of Haskell to synthesizable VHDL. It does this by translating the intermediate System Fc (GHC Core) representation to a VHDL AST, which is then written to file. @@ -38,4 +38,4 @@ Library CLasH.Utils.Pretty CLasH.Utils.Core.CoreShow CLasH.Utils.Core.CoreTools - \ No newline at end of file +