+{-# LANGUAGE TemplateHaskell #-}
+
module HighOrdAlu where
import Prelude hiding (
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
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
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.
build-depends: base > 4, clash, ghc-paths
extensions: PackageImports
exposed-modules: CLasH.Translator
-
\ No newline at end of file
+
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 =
-- 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
-- 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
-- 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
-- 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.
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
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)" .
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)" .
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
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
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
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
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)]
import Language.Haskell.TH
import Data.Data
-data CLasHAnn = TopEntity | InitState
+data CLasHAnn = TopEntity | InitState | TestInput | TestCycles
deriving (Show, Data, Typeable)
isTopEntity :: CLasHAnn -> Bool
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
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 _ = []
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
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"]
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]
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
------------------
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.
CLasH.Utils.Pretty
CLasH.Utils.Core.CoreShow
CLasH.Utils.Core.CoreTools
-
\ No newline at end of file
+
projects / matthijs / master-project / cλash.git / commitdiff