Merge branch 'master' of git://github.com/christiaanb/clash into cλash
authorMatthijs Kooijman <m.kooijman@student.utwente.nl>
Fri, 31 Jul 2009 09:26:59 +0000 (11:26 +0200)
committerMatthijs Kooijman <m.kooijman@student.utwente.nl>
Fri, 31 Jul 2009 09:26:59 +0000 (11:26 +0200)
* '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

13 files changed:
Bits.hs
HighOrdAlu.hs
cλash-nolibdir/clash-nolibdir.cabal
cλash/CLasH/Normalize.hs
cλash/CLasH/Normalize/NormalizeTools.hs
cλash/CLasH/Translator.hs
cλash/CLasH/Translator/Annotations.hs
cλash/CLasH/Utils/Core/CoreTools.hs
cλash/CLasH/VHDL.hs
cλash/CLasH/VHDL/Constants.hs
cλash/CLasH/VHDL/Generate.hs
cλash/CLasH/VHDL/VHDLTools.hs
cλash/clash.cabal

diff --git a/Bits.hs b/Bits.hs
index 435b04e1efc5cb0292b345111f5584a694cf2521..558a12b1f24b5b7465baecda7cc402eeabd84c30 100644 (file)
--- 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:
index eb92520676b82cca2ef6bb2ac3ba04b58baf4eaf..6b11350ca951e059be3593298ae82d2b83853585 100644 (file)
@@ -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
index a58db5383e864cd9aae8dfb784d74a194c9bf0d7..7ed083841f11d37c6057eadae492f3f9e0cead48 100644 (file)
@@ -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
+  
index 722461037a3e146b61a139cea1f432e0dabbdb5d..e69db2c4421c0f018bfab8a1aac78fc0a4c91ac3 100644 (file)
@@ -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 =
index e1b8727086011bcc1a85094ca8059fb5bcc2e784..7f575ade5480acb0b537599ddfab4f95d47d9841 100644 (file)
@@ -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.
index caa02071dbd6dcf9c476e18d24c493b7af398fae..a3471432e11b15067949690b75ee8ff13399d399 100644 (file)
@@ -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)]
index 08e7845086be4027970799f20e2032f51b558875..ff2bb4bd0c9d5d38465ca78dd56bc64dc674dba4 100644 (file)
@@ -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
index e0a5c11187fc4c8b3f63f42192f859b11519a5da..254f77acf08bb5ec30502ef37b6385593053ba96 100644 (file)
@@ -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 _ = []
index 031acc8dc238f77a07059ea2fcaefc33c62e93ee..60b4f8a5195d58ad0048a279940cb89cbdd7d543 100644 (file)
@@ -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)
index 317cb64d9ec9e8b9147441b76023fee14cdb6aad..d9ed855bf2f63b65ed8c8684147841c3df453ee1 100644 (file)
@@ -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
index 2c5f2d7f57809c11ec6aa90144c84aae56873538..4a62878af5f8756be751e2a9e28feeafe9496499 100644 (file)
@@ -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                ) )
   ]
index 8fd993834bf5a1a25cc44a9ae79a8ae7703aa71e..d1c008ec786949b1e4bc5c0d6b91a3adcd99ad10 100644 (file)
@@ -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
index 69fd79f4828e51e07dee1a2dfcbafa0188cca2d2..529772c1543cf69f865a021ed95ef5d5f17e539e 100644 (file)
@@ -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
+