From: Matthijs Kooijman Date: Fri, 31 Jul 2009 09:26:59 +0000 (+0200) Subject: Merge branch 'master' of git://github.com/christiaanb/clash into cλash X-Git-Url: https://git.stderr.nl/gitweb?a=commitdiff_plain;h=4b87be0b9d499155084a6240b016afd57b4b30cd;hp=bc592bd13167eac05619653e84857ee7ab5035c1;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git Merge branch 'master' of git://github.com/christiaanb/clash into cλash * 'master' of git://github.com/christiaanb/clash: Quick hack implementation of FSVec literals, needs to be fixed We need the latest vhdl package We now make a show function for all default datatypes. Add automated testbench generation according to supplied test input Conflicts: cλash/CLasH/Translator.hs --- diff --git a/Bits.hs b/Bits.hs index 435b04e..558a12b 100644 --- a/Bits.hs +++ b/Bits.hs @@ -1,11 +1,13 @@ -{-# 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 @@ -45,22 +47,22 @@ displaysig Low = "0" -- 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: diff --git a/HighOrdAlu.hs b/HighOrdAlu.hs index eb92520..6b11350 100644 --- a/HighOrdAlu.hs +++ b/HighOrdAlu.hs @@ -1,38 +1,51 @@ +{-# 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 @@ -43,6 +56,8 @@ 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 (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 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..e69db2c 100644 --- "a/c\316\273ash/CLasH/Normalize.hs" +++ "b/c\316\273ash/CLasH/Normalize.hs" @@ -102,10 +102,11 @@ letrectop = everywhere ("letrec", letrec) -------------------------------- 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. @@ -467,22 +468,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 caa0207..a347143 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 @@ -109,26 +111,26 @@ listBind libdir filename name = do -- | 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)" . @@ -137,15 +139,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)" . @@ -154,8 +156,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 @@ -202,7 +205,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 @@ -218,7 +221,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 @@ -234,6 +238,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 @@ -253,6 +264,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..254f77a 100644 --- "a/c\316\273ash/CLasH/Utils/Core/CoreTools.hs" +++ "b/c\316\273ash/CLasH/Utils/Core/CoreTools.hs" @@ -45,7 +45,7 @@ eval_tfp_int env ty = -- 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) @@ -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..60b4f8a 100644 --- "a/c\316\273ash/CLasH/VHDL.hs" +++ "b/c\316\273ash/CLasH/VHDL.hs" @@ -38,29 +38,35 @@ 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 - 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"] @@ -148,7 +154,7 @@ createEntityAST vhdl_id args res = ++ [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 :: @@ -234,15 +240,6 @@ getSignalId info = (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 :: @@ -296,3 +293,121 @@ 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) + (AST.NSimple $ eventId) + Nothing ) `AST.And` + (AST.PrimName (AST.NSimple clockId) AST.:=: AST.PrimLit "'1'") + writeOuts :: [AST.VHDLId] -> [AST.SeqSm] + writeOuts [] = [] + writeOuts [i] = [writeOut i (AST.PrimLit "LF")] + writeOuts (i:is) = writeOut i (AST.PrimLit "HT") : writeOuts is + writeOut outSig suffix = + genExprPCall2 writeId + (AST.PrimName $ AST.NSimple outputId) + ((genExprFCall showId (AST.PrimName $ AST.NSimple outSig)) AST.:&: suffix) diff --git "a/c\316\273ash/CLasH/VHDL/Constants.hs" "b/c\316\273ash/CLasH/VHDL/Constants.hs" index 317cb64..d9ed855 100644 --- "a/c\316\273ash/CLasH/VHDL/Constants.hs" +++ "b/c\316\273ash/CLasH/VHDL/Constants.hs" @@ -16,6 +16,8 @@ resetId, clockId :: AST.VHDLId resetId = AST.unsafeVHDLBasicId resetStr clockId = AST.unsafeVHDLBasicId clockStr +integerId :: AST.VHDLId +integerId = AST.unsafeVHDLBasicId "integer" -- | \"types\" identifier typesId :: AST.VHDLId @@ -261,6 +263,27 @@ toUnsignedId = "to_unsigned" 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 ------------------ @@ -296,3 +319,11 @@ signedTM = AST.unsafeVHDLBasicId "signed" -- | 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 diff --git "a/c\316\273ash/CLasH/VHDL/Generate.hs" "b/c\316\273ash/CLasH/VHDL/Generate.hs" index 2c5f2d7..4a62878 100644 --- "a/c\316\273ash/CLasH/VHDL/Generate.hs" +++ "b/c\316\273ash/CLasH/VHDL/Generate.hs" @@ -161,6 +161,39 @@ genFromInteger' (Left res) f lits = do { 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 @@ -248,7 +281,7 @@ genFold'' len left (Left res) f [folded_f, start, vec] = do 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 @@ -549,6 +582,17 @@ genApplication dst f args = do 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 @@ -561,7 +605,7 @@ genApplication dst f args = do 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. @@ -609,10 +653,8 @@ genUnconsVectorFuns :: AST.TypeMark -- ^ type of the vector elements 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],[])) @@ -658,7 +700,7 @@ genUnconsVectorFuns elemTM 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.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) @@ -667,23 +709,19 @@ genUnconsVectorFuns elemTM vectorTM = 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); @@ -693,34 +731,16 @@ genUnconsVectorFuns elemTM 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.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); @@ -746,14 +766,14 @@ genUnconsVectorFuns elemTM 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.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, @@ -765,7 +785,7 @@ genUnconsVectorFuns elemTM vectorTM = (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.:&: @@ -819,7 +839,7 @@ genUnconsVectorFuns elemTM vectorTM = -- 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.:*: @@ -837,7 +857,7 @@ genUnconsVectorFuns elemTM vectorTM = (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.:&: @@ -853,9 +873,9 @@ genUnconsVectorFuns elemTM vectorTM = (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.:= @@ -864,7 +884,7 @@ genUnconsVectorFuns elemTM vectorTM = 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); @@ -874,7 +894,7 @@ genUnconsVectorFuns elemTM 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.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-: (AST.PrimLit "1")) ])) Nothing -- res := a & init(vec) @@ -892,7 +912,7 @@ genUnconsVectorFuns elemTM 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.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-: (AST.PrimLit "1")) ])) Nothing -- res := tail(vec) & a @@ -906,7 +926,7 @@ genUnconsVectorFuns elemTM vectorTM = -- 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); @@ -916,7 +936,7 @@ genUnconsVectorFuns elemTM 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.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) @@ -940,7 +960,7 @@ genUnconsVectorFuns elemTM 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.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) @@ -963,24 +983,25 @@ genUnconsVectorFuns elemTM 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.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 @@ -1035,4 +1056,6 @@ globalNameTable = Map.fromList , (fromSizedWordId , (1, genFromSizedWord ) ) , (fromIntegerId , (1, genFromInteger ) ) , (resizeId , (1, genResize ) ) + , (sizedIntId , (1, genSizedInt ) ) + , (tfvecId , (1, genTFVec ) ) ] diff --git "a/c\316\273ash/CLasH/VHDL/VHDLTools.hs" "b/c\316\273ash/CLasH/VHDL/VHDLTools.hs" index 8fd9938..d1c008e 100644 --- "a/c\316\273ash/CLasH/VHDL/VHDLTools.hs" +++ "b/c\316\273ash/CLasH/VHDL/VHDLTools.hs" @@ -10,6 +10,7 @@ import qualified Control.Arrow as Arrow 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 @@ -115,7 +116,7 @@ mkComponentInst :: 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])) ----------------------------------------------------------------------------- @@ -320,12 +321,12 @@ construct_vhdl_ty ty = do 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") @@ -347,6 +348,8 @@ mk_tycon_ty tycon args = 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 $ @@ -391,7 +394,9 @@ mk_vector_ty ty = do let vec_id = mkVHDLExtId $ "vector_" ++ (AST.fromVHDLId el_ty_tm) let vec_def = AST.TDA $ AST.UnconsArrayDef [tfvec_indexTM] el_ty_tm modA vsTypes (Map.insert (StdType $ OrdType vec_ty) (vec_id, (Left vec_def))) - modA vsTypeDecls (\typedefs -> typedefs ++ [mktydecl (vec_id, (Left vec_def))]) + modA 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 @@ -418,6 +423,8 @@ mk_unsigned_ty ty = do 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 :: @@ -428,6 +435,8 @@ mk_signed_ty ty = do 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, @@ -457,7 +466,7 @@ mkHType ty = do 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 @@ -520,8 +529,25 @@ isReprType ty = do 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 @@ -531,4 +557,147 @@ tfp_to_int ty = do 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 diff --git "a/c\316\273ash/clash.cabal" "b/c\316\273ash/clash.cabal" index 69fd79f..529772c 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. @@ -17,9 +17,10 @@ maintainer: christiaan.baaij@gmail.com & matthijs@stdin.nl 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 @@ -38,4 +39,4 @@ Library CLasH.Utils.Pretty CLasH.Utils.Core.CoreShow CLasH.Utils.Core.CoreTools - \ No newline at end of file +