-{-# LANGUAGE FlexibleContexts,GADTs,ExistentialQuantification,LiberalTypeSynonyms,TemplateHaskell #-}
+{-# LANGUAGE FlexibleContexts,GADTs,ExistentialQuantification,LiberalTypeSynonyms,TemplateHaskell, DeriveDataTypeable #-}
module Bits where
-import qualified Data.Param.TFVec as TFVec
-import qualified Types
+-- import qualified Data.Param.TFVec as TFVec
+-- import qualified Types
import Language.Haskell.TH.Lift
+import Data.Typeable
+
--class Signal a where
-- hwand :: a -> a -> a
-- hwor :: a -> a -> a
-- The plain Bit type
data Bit = High | Low
- deriving (Show, Eq, Read)
+ deriving (Show, Eq, Read, Typeable)
$(deriveLift1 ''Bit)
-- A function to prettyprint a bitvector
--displaysigs :: (Signal s) => [s] -> String
-displaysigs :: [Bit] -> String
-displaysigs = (foldl (++) "") . (map displaysig)
+-- displaysigs :: [Bit] -> String
+-- displaysigs = (foldl (++) "") . (map displaysig)
-type Stream a = [a]
+-- type Stream a = [a]
-- An infinite streams of highs or lows
-lows = Low : lows
-highs = High : highs
-
-type BitVec len = TFVec.TFVec len Bit
+-- lows = Low : lows
+-- highs = High : highs
+--
+-- type BitVec len = TFVec.TFVec len Bit
-- vim: set ts=8 sw=2 sts=2 expandtab:
+{-# LANGUAGE TemplateHaskell, ScopedTypeVariables #-}
+
module HighOrdAlu where
+import qualified Prelude as P
import Prelude hiding (
null, length, head, tail, last, init, take, drop, (++), map, foldl, foldr,
zipWith, zip, unzip, concat, reverse, iterate )
import Bits
-import Types
+-- import Types
+import Types.Data.Num.Ops
+import Types.Data.Num.Decimal.Digits
+import Types.Data.Num.Decimal.Ops
+import Types.Data.Num.Decimal.Literals
import Data.Param.TFVec
import Data.RangedWord
+import Data.SizedInt
import CLasH.Translator.Annotations
-constant :: e -> Op D4 e
-constant e a b =
- (e +> (e +> (e +> (singleton e))))
+constant :: NaturalT n => e -> Op n e
+constant e a b = copy e
invop :: Op n Bit
invop a b = map hwnot a
-andop :: Op n Bit
-andop a b = zipWith hwand a b
+andop :: (e -> e -> e) -> Op n e
+andop f a b = zipWith f a b
-- Is any bit set?
--anyset :: (PositiveT n) => Op n Bit
-anyset :: (Bit -> Bit -> Bit) -> Op D4 Bit
+anyset :: NaturalT n => (e -> e -> e) -> e -> Op n e
--anyset a b = copy undefined (a' `hwor` b')
-anyset f a b = constant (a' `hwor` b') a b
+anyset f s a b = constant (f a' b') a b
where
- a' = foldl f Low a
- b' = foldl f Low b
+ a' = foldl f s a
+ b' = foldl f s b
xhwor = hwor
type Op n e = (TFVec n e -> TFVec n e -> TFVec n e)
type Opcode = Bit
+{-# ANN sim_input TestInput#-}
+sim_input :: [(Opcode, TFVec D4 (SizedInt D8), TFVec D4 (SizedInt D8))]
+sim_input = [ (High, $(vectorTH ([4,3,2,1]::[SizedInt D8])), $(vectorTH ([1,2,3,4]::[SizedInt D8])))
+ , (High, $(vectorTH ([4,3,2,1]::[SizedInt D8])), $(vectorTH ([1,2,3,4]::[SizedInt D8])))
+ , (Low, $(vectorTH ([4,3,2,1]::[SizedInt D8])), $(vectorTH ([1,2,3,4]::[SizedInt D8]))) ]
+
{-# 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 (SizedInt D8), TFVec D4 (SizedInt D8)) -> TFVec D4 (SizedInt D8)
--actual_alu = alu (constant Low) andop
-actual_alu = alu (anyset xhwor) andop
+actual_alu (opc, a, b) = alu (anyset (+) (0 :: SizedInt D8)) (andop (-)) opc a b
+
+runalu = P.map actual_alu sim_input
\ No newline at end of file
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
+
--------------------------------
letsimpl, letsimpltop :: Transform
-- Put the "in ..." value of a let in its own binding, but not when the
--- expression is applicable (to prevent loops with inlinefun).
-letsimpl expr@(Let (Rec binds) res) | not $ is_applicable expr = do
+-- expression is already a local variable, or not representable (to prevent loops with inlinenonrep).
+letsimpl expr@(Let (Rec binds) res) = do
+ repr <- isRepr res
local_var <- Trans.lift $ is_local_var res
- if not local_var
+ if not local_var && repr
then do
-- If the result is not a local var already (to prevent loops with
-- ourselves), extract it.
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
-- | 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
-- Automatically import modules for any fully qualified identifiers
setDynFlag DynFlags.Opt_ImplicitImportQualified
- let from_int_t_name = mkRdrName "Types.Data.Num" "fromIntegerT"
+ let from_int_t_name = mkRdrName "Types.Data.Num.Ops" "fromIntegerT"
let from_int_t = SrcLoc.noLoc $ HsExpr.HsVar from_int_t_name
let undef = hsTypedUndef $ coreToHsType ty
let app = SrcLoc.noLoc $ HsExpr.HsApp (from_int_t) (undef)
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
- tyfun_decls = map snd $ Map.elems (final_session ^. vsType ^. vsTypeFuns)
+ (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) highId Nothing)
+ 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 ["IEEE", "numeric_std"],
+ mkUseAll ["std", "textio"]
]
full_context =
mkUseAll ["work", "types"]
++ [mkIfaceSigDec AST.Out res]
++ [clk_port]
-- Add a clk port if we have state
- clk_port = AST.IfaceSigDec (mkVHDLExtId "clk") AST.In std_logicTM
+ clk_port = AST.IfaceSigDec clockId AST.In std_logicTM
-- | Create a port declaration
mkIfaceSigDec ::
(error $ "Unnamed signal? This should not happen!")
(sigName info)
-}
-
-mkSigDec :: CoreSyn.CoreBndr -> VHDLSession (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)
- return $ Just (AST.SigDec (varToVHDLId bndr) type_mark Nothing)
- else
- return Nothing
-- | Transforms a core binding into a VHDL concurrent statement
mkConcSm ::
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)
resetId = AST.unsafeVHDLBasicId resetStr
clockId = AST.unsafeVHDLBasicId clockStr
+integerId :: AST.VHDLId
+integerId = AST.unsafeVHDLBasicId "integer"
-- | \"types\" identifier
typesId :: AST.VHDLId
resizeId :: String
resizeId = "resize"
+sizedIntId :: String
+sizedIntId = "SizedInt"
+
+tfvecId :: String
+tfvecId = "TFVec"
+
+-- | output file identifier (from std.textio)
+showIdString :: String
+showIdString = "show"
+
+showId :: AST.VHDLId
+showId = AST.unsafeVHDLExtId 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
------------------
-- | unsigned TypeMark
unsignedTM :: AST.TypeMark
unsignedTM = AST.unsafeVHDLBasicId "unsigned"
+
+-- | string TypeMark
+stringTM :: AST.TypeMark
+stringTM = AST.unsafeVHDLBasicId "string"
+
+-- | tup VHDLName suffix
+tupVHDLSuffix :: AST.VHDLId -> AST.Suffix
+tupVHDLSuffix id = AST.SSimple id
\ No newline at end of file
genFromInteger' (Right name) _ _ = error $ "\nGenerate.genFromInteger': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
+genSizedInt :: BuiltinBuilder
+genSizedInt = genFromInteger
+
+genTFVec :: BuiltinBuilder
+genTFVec (Left res) f [Left veclist] = do {
+ ; let (CoreSyn.Let (CoreSyn.Rec [(bndr, app@(CoreSyn.App _ _))]) rez) = veclist
+ ; let (CoreSyn.Var f, args) = CoreSyn.collectArgs app
+ ; let valargs = get_val_args (Var.varType f) args
+ ; apps <- genApplication (Left bndr) f (map Left valargs)
+ ; (aap,kooi) <- reduceFSVECListToHsList rez
+ ; sigs <- mapM (\x -> MonadState.lift vsType $ varToVHDLExpr x) (bndr:aap)
+ ; let vecsigns = concatsigs sigs
+ ; let vecassign = mkUncondAssign (Left res) vecsigns
+ ; sig_dec_maybes <- mapM mkSigDec (bndr:aap)
+ ; let sig_decs = map (AST.BDISD) (Maybe.catMaybes $ sig_dec_maybes)
+ ; let block_label = mkVHDLExtId ("FSVec_" ++ (show (map varToString (bndr:aap))))
+ ; let block = AST.BlockSm block_label [] (AST.PMapAspect []) sig_decs (apps ++ kooi ++ [vecassign])
+ ; return $ [AST.CSBSm block]
+ }
+ where
+ concatsigs x = AST.Aggregate (map (\z -> AST.ElemAssoc Nothing z) x)
+
+
+reduceFSVECListToHsList app@(CoreSyn.App _ letexpr) = do
+ case letexpr of
+ (CoreSyn.Let (CoreSyn.Rec [(bndr, app@(CoreSyn.App _ _))]) rez) -> do
+ let (CoreSyn.Var f, args) = CoreSyn.collectArgs app
+ let valargs = get_val_args (Var.varType f) args
+ app <- genApplication (Left bndr) f (map Left valargs)
+ (vars, apps) <- reduceFSVECListToHsList rez
+ return ((bndr:vars),(app ++ apps))
+ otherwise -> return ([],[])
+
-- | Generate a generate statement for the builtin function "map"
genMap :: BuiltinBuilder
tmp_vhdl_ty <- MonadState.lift vsType $ vhdl_ty error_msg tmp_ty
-- Setup the generate scheme
let gen_label = mkVHDLExtId ("foldlVector" ++ (varToString vec))
- let block_label = mkVHDLExtId ("foldlVector" ++ (varToString start))
+ let block_label = mkVHDLExtId ("foldlVector" ++ (varToString res))
let gen_range = if left then AST.ToRange (AST.PrimLit "0") len_min_expr
else AST.DownRange len_min_expr (AST.PrimLit "0")
let gen_scheme = AST.ForGn n_id gen_range
let sel_name = mkSelectedName ((either varToVHDLName id) dst) label in
mkUncondAssign (Right sel_name) arg
Right _ -> error $ "\nGenerate.genApplication: Can't generate dataconstructor application without an original binder"
+ IdInfo.DataConWrapId dc -> case dst of
+ -- It's a datacon. Create a record from its arguments.
+ Left bndr -> do
+ case (Map.lookup (varToString f) globalNameTable) of
+ Just (arg_count, builder) ->
+ if length args == arg_count then
+ builder dst f args
+ else
+ error $ "\nGenerate.genApplication(DataConWrapId): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args
+ Nothing -> error $ "\nGenerate.genApplication: Can't generate dataconwrapper: " ++ (show dc)
+ Right _ -> error $ "\nGenerate.genApplication: Can't generate dataconwrapper application without an original binder"
IdInfo.VanillaId -> do
-- It's a global value imported from elsewhere. These can be builtin
-- functions. Look up the function name in the name table and execute
builder dst f args
else
error $ "\nGenerate.genApplication(VanillaGlobal): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args
- Nothing -> error $ "\nGenerate.genApplication(VanillaGlobal): Using function from another module that is not a known builtin: " ++ pprString f
+ Nothing -> return $ trace ("\nGenerate.genApplication(VanillaGlobal): Using function from another module that is not a known builtin: " ++ (pprString f)) []
IdInfo.ClassOpId cls -> do
-- FIXME: Not looking for what instance this class op is called for
-- Is quite stupid of course.
genUnconsVectorFuns elemTM vectorTM =
[ (exId, (AST.SubProgBody exSpec [] [exExpr],[]))
, (replaceId, (AST.SubProgBody replaceSpec [AST.SPVD replaceVar] [replaceExpr,replaceRet],[]))
- , (headId, (AST.SubProgBody headSpec [] [headExpr],[]))
, (lastId, (AST.SubProgBody lastSpec [] [lastExpr],[]))
, (initId, (AST.SubProgBody initSpec [AST.SPVD initVar] [initExpr, initRet],[]))
- , (tailId, (AST.SubProgBody tailSpec [AST.SPVD tailVar] [tailExpr, tailRet],[]))
, (takeId, (AST.SubProgBody takeSpec [AST.SPVD takeVar] [takeExpr, takeRet],[]))
, (dropId, (AST.SubProgBody dropSpec [AST.SPVD dropVar] [dropExpr, dropRet],[]))
, (plusgtId, (AST.SubProgBody plusgtSpec [AST.SPVD plusgtVar] [plusgtExpr, plusgtRet],[]))
(Just $ AST.ConstraintIndex $ AST.IndexConstraint
[AST.ToRange (AST.PrimLit "0")
(AST.PrimName (AST.NAttribute $
- AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing) AST.:-:
+ AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
(AST.PrimLit "1")) ]))
Nothing
-- res AST.:= vec(0 to i-1) & a & vec(i+1 to length'vec-1)
AST.PrimName (AST.NSimple aPar) AST.:&:
vecSlice (AST.PrimName (AST.NSimple iPar) AST.:+: AST.PrimLit "1")
((AST.PrimName (AST.NAttribute $
- AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing))
+ AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))
AST.:-: AST.PrimLit "1"))
replaceRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
vecSlice init last = AST.PrimName (AST.NSlice
(AST.SliceName
(AST.NSimple vecPar)
(AST.ToRange init last)))
- headSpec = AST.Function (mkVHDLExtId headId) [AST.IfaceVarDec vecPar vectorTM] elemTM
- -- return vec(0);
- headExpr = AST.ReturnSm (Just $ (AST.PrimName $ AST.NIndexed (AST.IndexedName
- (AST.NSimple vecPar) [AST.PrimLit "0"])))
lastSpec = AST.Function (mkVHDLExtId lastId) [AST.IfaceVarDec vecPar vectorTM] elemTM
-- return vec(vec'length-1);
lastExpr = AST.ReturnSm (Just $ (AST.PrimName $ AST.NIndexed (AST.IndexedName
(AST.NSimple vecPar)
[AST.PrimName (AST.NAttribute $
- AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing)
+ AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing)
AST.:-: AST.PrimLit "1"])))
initSpec = AST.Function (mkVHDLExtId initId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
-- variable res : fsvec_x (0 to vec'length-2);
(Just $ AST.ConstraintIndex $ AST.IndexConstraint
[AST.ToRange (AST.PrimLit "0")
(AST.PrimName (AST.NAttribute $
- AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing) AST.:-:
+ AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
(AST.PrimLit "2")) ]))
Nothing
-- resAST.:= vec(0 to vec'length-2)
initExpr = AST.NSimple resId AST.:= (vecSlice
(AST.PrimLit "0")
(AST.PrimName (AST.NAttribute $
- AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing)
+ AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing)
AST.:-: AST.PrimLit "2"))
initRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
- tailSpec = AST.Function (mkVHDLExtId tailId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
- -- variable res : fsvec_x (0 to vec'length-2);
- tailVar =
- AST.VarDec resId
- (AST.SubtypeIn vectorTM
- (Just $ AST.ConstraintIndex $ AST.IndexConstraint
- [AST.ToRange (AST.PrimLit "0")
- (AST.PrimName (AST.NAttribute $
- AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing) AST.:-:
- (AST.PrimLit "2")) ]))
- Nothing
- -- res AST.:= vec(1 to vec'length-1)
- tailExpr = AST.NSimple resId AST.:= (vecSlice
- (AST.PrimLit "1")
- (AST.PrimName (AST.NAttribute $
- AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing)
- AST.:-: AST.PrimLit "1"))
- tailRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
takeSpec = AST.Function (mkVHDLExtId takeId) [AST.IfaceVarDec nPar naturalTM,
AST.IfaceVarDec vecPar vectorTM ] vectorTM
-- variable res : fsvec_x (0 to n-1);
(Just $ AST.ConstraintIndex $ AST.IndexConstraint
[AST.ToRange (AST.PrimLit "0")
(AST.PrimName (AST.NAttribute $
- AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing) AST.:-:
+ AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
(AST.PrimName $ AST.NSimple nPar)AST.:-: (AST.PrimLit "1")) ]))
Nothing
-- res AST.:= vec(n to vec'length-1)
dropExpr = AST.NSimple resId AST.:= (vecSlice
(AST.PrimName $ AST.NSimple nPar)
(AST.PrimName (AST.NAttribute $
- AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing)
+ AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing)
AST.:-: AST.PrimLit "1"))
dropRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
plusgtSpec = AST.Function (mkVHDLExtId plusgtId) [AST.IfaceVarDec aPar elemTM,
(Just $ AST.ConstraintIndex $ AST.IndexConstraint
[AST.ToRange (AST.PrimLit "0")
(AST.PrimName (AST.NAttribute $
- AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing))]))
+ AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))]))
Nothing
plusgtExpr = AST.NSimple resId AST.:=
((AST.PrimName $ AST.NSimple aPar) AST.:&:
-- for i res'range loop
-- res(i) := vec(f+i*s);
-- end loop;
- selFor = AST.ForSM iId (AST.AttribRange $ AST.AttribName (AST.NSimple resId) rangeId Nothing) [selAssign]
+ selFor = AST.ForSM iId (AST.AttribRange $ AST.AttribName (AST.NSimple resId) (AST.NSimple $ rangeId) Nothing) [selAssign]
-- res(i) := vec(f+i*s);
selAssign = let origExp = AST.PrimName (AST.NSimple fPar) AST.:+:
(AST.PrimName (AST.NSimple iId) AST.:*:
(Just $ AST.ConstraintIndex $ AST.IndexConstraint
[AST.ToRange (AST.PrimLit "0")
(AST.PrimName (AST.NAttribute $
- AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing))]))
+ AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))]))
Nothing
ltplusExpr = AST.NSimple resId AST.:=
((AST.PrimName $ AST.NSimple vecPar) AST.:&:
(Just $ AST.ConstraintIndex $ AST.IndexConstraint
[AST.ToRange (AST.PrimLit "0")
(AST.PrimName (AST.NAttribute $
- AST.AttribName (AST.NSimple vec1Par) (mkVHDLBasicId lengthId) Nothing) AST.:+:
+ AST.AttribName (AST.NSimple vec1Par) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:+:
AST.PrimName (AST.NAttribute $
- AST.AttribName (AST.NSimple vec2Par) (mkVHDLBasicId lengthId) Nothing) AST.:-:
+ AST.AttribName (AST.NSimple vec2Par) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
AST.PrimLit "1")]))
Nothing
plusplusExpr = AST.NSimple resId AST.:=
plusplusRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
lengthTSpec = AST.Function (mkVHDLExtId lengthTId) [AST.IfaceVarDec vecPar vectorTM] naturalTM
lengthTExpr = AST.ReturnSm (Just $ AST.PrimName (AST.NAttribute $
- AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing))
+ AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))
shiftlSpec = AST.Function (mkVHDLExtId shiftlId) [AST.IfaceVarDec vecPar vectorTM,
AST.IfaceVarDec aPar elemTM ] vectorTM
-- variable res : fsvec_x (0 to vec'length-1);
(Just $ AST.ConstraintIndex $ AST.IndexConstraint
[AST.ToRange (AST.PrimLit "0")
(AST.PrimName (AST.NAttribute $
- AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing) AST.:-:
+ AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
(AST.PrimLit "1")) ]))
Nothing
-- res := a & init(vec)
(Just $ AST.ConstraintIndex $ AST.IndexConstraint
[AST.ToRange (AST.PrimLit "0")
(AST.PrimName (AST.NAttribute $
- AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing) AST.:-:
+ AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
(AST.PrimLit "1")) ]))
Nothing
-- res := tail(vec) & a
-- return vec'length = 0
nullExpr = AST.ReturnSm (Just $
AST.PrimName (AST.NAttribute $
- AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing) AST.:=:
+ AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:=:
AST.PrimLit "0")
rotlSpec = AST.Function (mkVHDLExtId rotlId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
-- variable res : fsvec_x (0 to vec'length-1);
(Just $ AST.ConstraintIndex $ AST.IndexConstraint
[AST.ToRange (AST.PrimLit "0")
(AST.PrimName (AST.NAttribute $
- AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing) AST.:-:
+ AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
(AST.PrimLit "1")) ]))
Nothing
-- if null(vec) then res := vec else res := last(vec) & init(vec)
(Just $ AST.ConstraintIndex $ AST.IndexConstraint
[AST.ToRange (AST.PrimLit "0")
(AST.PrimName (AST.NAttribute $
- AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing) AST.:-:
+ AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
(AST.PrimLit "1")) ]))
Nothing
-- if null(vec) then res := vec else res := tail(vec) & head(vec)
(Just $ AST.ConstraintIndex $ AST.IndexConstraint
[AST.ToRange (AST.PrimLit "0")
(AST.PrimName (AST.NAttribute $
- AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing) AST.:-:
+ AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
(AST.PrimLit "1")) ]))
Nothing
-- for i in 0 to res'range loop
-- res(vec'length-i-1) := vec(i);
-- end loop;
reverseFor =
- AST.ForSM iId (AST.AttribRange $ AST.AttribName (AST.NSimple resId) rangeId Nothing) [reverseAssign]
+ AST.ForSM iId (AST.AttribRange $ AST.AttribName (AST.NSimple resId) (AST.NSimple $ rangeId) Nothing) [reverseAssign]
-- res(vec'length-i-1) := vec(i);
reverseAssign = AST.NIndexed (AST.IndexedName (AST.NSimple resId) [destExp]) AST.:=
(AST.PrimName $ AST.NIndexed (AST.IndexedName (AST.NSimple vecPar)
[AST.PrimName $ AST.NSimple iId]))
where destExp = AST.PrimName (AST.NAttribute $ AST.AttribName (AST.NSimple vecPar)
- (mkVHDLBasicId lengthId) Nothing) AST.:-:
+ (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
AST.PrimName (AST.NSimple iId) AST.:-:
(AST.PrimLit "1")
-- return res;
reverseRet = AST.ReturnSm (Just $ AST.PrimName (AST.NSimple resId))
+
-----------------------------------------------------------------------------
-- A table of builtin functions
, (fromSizedWordId , (1, genFromSizedWord ) )
, (fromIntegerId , (1, genFromInteger ) )
, (resizeId , (1, genResize ) )
+ , (sizedIntId , (1, genSizedInt ) )
+ , (tfvecId , (1, genTFVec ) )
]
import qualified Control.Monad.Trans.State as State
import qualified Data.Monoid as Monoid
import Data.Accessor
+import Data.Accessor.MonadState as MonadState
import Debug.Trace
-- ForSyDe
mkComponentInst label entity_id portassigns = AST.CSISm compins
where
-- We always have a clock port, so no need to map it anywhere but here
- clk_port = mkAssocElem (mkVHDLExtId "clk") (idToVHDLExpr $ mkVHDLExtId "clk")
+ clk_port = mkAssocElem clockId (idToVHDLExpr clockId)
compins = AST.CompInsSm (mkVHDLExtId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect (portassigns ++ [clk_port]))
-----------------------------------------------------------------------------
bound <- tfp_to_int (ranged_word_bound_ty ty)
mk_natural_ty 0 bound
-- Create a custom type from this tycon
- otherwise -> mk_tycon_ty tycon args
+ otherwise -> mk_tycon_ty ty tycon args
Nothing -> return (Left $ "VHDLTools.construct_vhdl_ty: Cannot create type for non-tycon type: " ++ pprString ty ++ "\n")
-- | Create VHDL type for a custom tycon
-mk_tycon_ty :: TyCon.TyCon -> [Type.Type] -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
-mk_tycon_ty tycon args =
+mk_tycon_ty :: Type.Type -> TyCon.TyCon -> [Type.Type] -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
+mk_tycon_ty ty tycon args =
case TyCon.tyConDataCons tycon of
-- Not an algebraic type
[] -> return (Left $ "VHDLTools.mk_tycon_ty: Only custom algebraic types are supported: " ++ pprString tycon ++ "\n")
let elem_names = concat $ map prettyShow elem_tys
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)
return $ Right (ty_id, Left ty_def)
-- There were errors in element types
(errors, _) -> return $ Left $
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 vsTypeDecls (\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
let ty_def = AST.SubtypeIn vec_id (Just range)
return (Right (ty_id, Right ty_def))
-- Could not create element type
let ty_id = mkVHDLExtId $ "unsigned_" ++ show (size - 1)
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)
return (Right (ty_id, Right ty_def))
mk_signed_ty ::
let ty_id = mkVHDLExtId $ "signed_" ++ show (size - 1)
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)
return (Right (ty_id, Right ty_def))
-- Finds the field labels for VHDL type generated for the given Core type,
let name = Name.getOccString (TyCon.tyConName tycon)
Map.lookup name builtin_types
case builtin_ty of
- Just typ ->
+ Just typ ->
return $ Right $ BuiltinType $ prettyShow typ
Nothing ->
case Type.splitTyConApp_maybe ty of
Left _ -> False
Right _ -> True
+
tfp_to_int :: Type.Type -> TypeSession Int
tfp_to_int ty = do
+ hscenv <- getA vsHscEnv
+ let norm_ty = normalise_tfp_int hscenv ty
+ case Type.splitTyConApp_maybe norm_ty of
+ Just (tycon, args) -> do
+ let name = Name.getOccString (TyCon.tyConName tycon)
+ case name of
+ "Dec" -> do
+ len <- tfp_to_int' ty
+ return len
+ otherwise -> do
+ modA vsTfpInts (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
let norm_ty = normalise_tfp_int hscenv ty
Nothing -> do
let new_len = eval_tfp_int hscenv ty
modA vsTfpInts (Map.insert (OrdType norm_ty) (new_len))
- return new_len
\ No newline at end of file
+ return new_len
+
+mkTupleShow ::
+ [AST.TypeMark] -- ^ type of each tuple element
+ -> AST.TypeMark -- ^ type of the tuple
+ -> AST.SubProgBody
+mkTupleShow elemTMs tupleTM = AST.SubProgBody showSpec [] [showExpr]
+ where
+ tupPar = AST.unsafeVHDLBasicId "tup"
+ showSpec = AST.Function showId [AST.IfaceVarDec tupPar tupleTM] stringTM
+ showExpr = AST.ReturnSm (Just $
+ AST.PrimLit "'('" AST.:&: showMiddle AST.:&: AST.PrimLit "')'")
+ where
+ showMiddle = foldr1 (\e1 e2 -> e1 AST.:&: AST.PrimLit "','" AST.:&: e2) $
+ map ((genExprFCall showId).
+ AST.PrimName .
+ AST.NSelected .
+ (AST.NSimple tupPar AST.:.:).
+ tupVHDLSuffix)
+ (take tupSize recordlabels)
+ recordlabels = map (\c -> mkVHDLBasicId [c]) ['A'..'Z']
+ tupSize = length elemTMs
+
+mkVectorShow ::
+ AST.TypeMark -- ^ elemtype
+ -> AST.TypeMark -- ^ vectype
+ -> [(String,AST.SubProgBody)]
+mkVectorShow elemTM vectorTM =
+ [ (headId, AST.SubProgBody headSpec [] [headExpr])
+ , (tailId, AST.SubProgBody tailSpec [AST.SPVD tailVar] [tailExpr, tailRet])
+ , (showIdString, AST.SubProgBody showSpec [AST.SPSB doShowDef] [showRet])
+ ]
+ where
+ vecPar = AST.unsafeVHDLBasicId "vec"
+ resId = AST.unsafeVHDLBasicId "res"
+ headSpec = AST.Function (mkVHDLExtId headId) [AST.IfaceVarDec vecPar vectorTM] elemTM
+ -- return vec(0);
+ headExpr = AST.ReturnSm (Just $ (AST.PrimName $ AST.NIndexed (AST.IndexedName
+ (AST.NSimple vecPar) [AST.PrimLit "0"])))
+ vecSlice init last = AST.PrimName (AST.NSlice
+ (AST.SliceName
+ (AST.NSimple vecPar)
+ (AST.ToRange init last)))
+ tailSpec = AST.Function (mkVHDLExtId tailId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
+ -- variable res : fsvec_x (0 to vec'length-2);
+ tailVar =
+ AST.VarDec resId
+ (AST.SubtypeIn vectorTM
+ (Just $ AST.ConstraintIndex $ AST.IndexConstraint
+ [AST.ToRange (AST.PrimLit "0")
+ (AST.PrimName (AST.NAttribute $
+ AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
+ (AST.PrimLit "2")) ]))
+ Nothing
+ -- res AST.:= vec(1 to vec'length-1)
+ tailExpr = AST.NSimple resId AST.:= (vecSlice
+ (AST.PrimLit "1")
+ (AST.PrimName (AST.NAttribute $
+ AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing)
+ AST.:-: AST.PrimLit "1"))
+ tailRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
+ showSpec = AST.Function showId [AST.IfaceVarDec vecPar vectorTM] stringTM
+ doShowId = AST.unsafeVHDLExtId "doshow"
+ doShowDef = AST.SubProgBody doShowSpec [] [doShowRet]
+ where doShowSpec = AST.Function doShowId [AST.IfaceVarDec vecPar vectorTM]
+ stringTM
+ -- case vec'len is
+ -- when 0 => return "";
+ -- when 1 => return head(vec);
+ -- when others => return show(head(vec)) & ',' &
+ -- doshow (tail(vec));
+ -- end case;
+ doShowRet =
+ AST.CaseSm (AST.PrimName (AST.NAttribute $
+ AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))
+ [AST.CaseSmAlt [AST.ChoiceE $ AST.PrimLit "0"]
+ [AST.ReturnSm (Just $ AST.PrimLit "\"\"")],
+ AST.CaseSmAlt [AST.ChoiceE $ AST.PrimLit "1"]
+ [AST.ReturnSm (Just $
+ genExprFCall showId
+ (genExprFCall (mkVHDLExtId headId) (AST.PrimName $ AST.NSimple vecPar)) )],
+ AST.CaseSmAlt [AST.Others]
+ [AST.ReturnSm (Just $
+ genExprFCall showId
+ (genExprFCall (mkVHDLExtId headId) (AST.PrimName $ AST.NSimple vecPar)) AST.:&:
+ AST.PrimLit "','" AST.:&:
+ genExprFCall doShowId
+ (genExprFCall (mkVHDLExtId tailId) (AST.PrimName $ AST.NSimple vecPar)) ) ]]
+ -- return '<' & doshow(vec) & '>';
+ showRet = AST.ReturnSm (Just $ AST.PrimLit "'<'" AST.:&:
+ genExprFCall doShowId (AST.PrimName $ AST.NSimple vecPar) AST.:&:
+ AST.PrimLit "'>'" )
+
+mkIntegerShow ::
+ AST.TypeMark -- ^ The specific signed
+ -> AST.SubProgBody
+mkIntegerShow signedTM = AST.SubProgBody showSpec [] [showExpr]
+ where
+ signedPar = AST.unsafeVHDLBasicId "sint"
+ showSpec = AST.Function showId [AST.IfaceVarDec signedPar signedTM] stringTM
+ showExpr = AST.ReturnSm (Just $
+ AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerId)
+ (AST.NIndexed $ AST.IndexedName (AST.NSimple imageId) [signToInt]) Nothing )
+ where
+ signToInt = genExprFCall (mkVHDLBasicId toIntegerId) (AST.PrimName $ AST.NSimple $ signedPar)
+
+mkBuiltInShow :: [AST.SubProgBody]
+mkBuiltInShow = [ AST.SubProgBody showBitSpec [] [showBitExpr]
+ , AST.SubProgBody showBoolSpec [] [showBoolExpr]
+ ]
+ where
+ bitPar = AST.unsafeVHDLBasicId "s"
+ boolPar = AST.unsafeVHDLBasicId "b"
+ showBitSpec = AST.Function showId [AST.IfaceVarDec bitPar std_logicTM] stringTM
+ -- if s = '1' then return "'1'" else return "'0'"
+ showBitExpr = AST.IfSm (AST.PrimName (AST.NSimple bitPar) AST.:=: AST.PrimLit "'1'")
+ [AST.ReturnSm (Just $ AST.PrimLit "\"High\"")]
+ []
+ (Just $ AST.Else [AST.ReturnSm (Just $ AST.PrimLit "\"Low\"")])
+ showBoolSpec = AST.Function showId [AST.IfaceVarDec boolPar booleanTM] stringTM
+ -- if b then return "True" else return "False"
+ showBoolExpr = AST.IfSm (AST.PrimName (AST.NSimple boolPar))
+ [AST.ReturnSm (Just $ AST.PrimLit "\"True\"")]
+ []
+ (Just $ AST.Else [AST.ReturnSm (Just $ AST.PrimLit "\"False\"")])
+
+genExprFCall :: AST.VHDLId -> AST.Expr -> AST.Expr
+genExprFCall fName args =
+ AST.PrimFCall $ AST.FCall (AST.NSimple fName) $
+ map (\exp -> Nothing AST.:=>: AST.ADExpr exp) [args]
+
+genExprPCall2 :: AST.VHDLId -> AST.Expr -> AST.Expr -> AST.SeqSm
+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 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)
+ return $ Just (AST.SigDec (varToVHDLId bndr) type_mark Nothing)
+ else
+ return Nothing
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.
Cabal-Version: >= 1.2
Library
- build-depends: ghc >= 6.11, pretty, vhdl, haskell98, syb, data-accessor,
- containers, base >= 4, transformers, filepath,
- template-haskell, data-accessor-template, prettyclass
+ build-depends: ghc >= 6.11, pretty, vhdl > 0.1, haskell98, syb,
+ data-accessor, containers, base >= 4, transformers,
+ filepath, template-haskell, data-accessor-template,
+ prettyclass
exposed-modules: CLasH.Translator,
CLasH.Translator.Annotations
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