Clean up source files:

- Remove unused imports
- Remove unneeded '$'
- Remove unneeded 'do'
- Remove unneeded 'return'
- Replace 'concat $ map' by 'concatMap'
- Replace 'mapM' by 'mapM_' if return value is not stored
- Replace 'not $ x `elem` xs' by 'x `notElem` xs'

diff --git a/cλash/CLasH/HardwareTypes.hs b/cλash/CLasH/HardwareTypes.hs
index e6e84fd8a33a13aade58bbf5d4167552ba4afab0..3b746aa242b702a9239b4dbcabd6d0fb34df0a4d 100644 (file)
--- a/cλash/CLasH/HardwareTypes.hs
+++ b/cλash/CLasH/HardwareTypes.hs
@@ -51,7 +51,7 @@ resizeWord = SizedWord.resize
 data Bit = High | Low
   deriving (P.Show, P.Eq, P.Read, Typeable)
 
 data Bit = High | Low
   deriving (P.Show, P.Eq, P.Read, Typeable)
 

-$(deriveLift1 ''Bit)
+deriveLift1 ''Bit

 
 hwand :: Bit -> Bit -> Bit
 hwor  :: Bit -> Bit -> Bit
 
 hwand :: Bit -> Bit -> Bit
 hwor  :: Bit -> Bit -> Bit

diff --git a/cλash/CLasH/Normalize.hs b/cλash/CLasH/Normalize.hs
index 40eab93c3787e27d9b599d939aeccd8e77264352..17143ffb6d857d555f2f52a30d9d99ab7eb4752b 100644 (file)
--- a/cλash/CLasH/Normalize.hs
+++ b/cλash/CLasH/Normalize.hs
@@ -13,32 +13,23 @@ import qualified List
 import qualified "transformers" Control.Monad.Trans as Trans
 import qualified Control.Monad as Monad
 import qualified Control.Monad.Trans.Writer as Writer
 import qualified "transformers" Control.Monad.Trans as Trans
 import qualified Control.Monad as Monad
 import qualified Control.Monad.Trans.Writer as Writer

-import qualified Data.Map as Map

 import qualified Data.Monoid as Monoid
 import qualified Data.Monoid as Monoid

-import Data.Accessor

 
 -- GHC API
 import CoreSyn
 
 -- GHC API
 import CoreSyn

-import qualified UniqSupply

 import qualified CoreUtils
 import qualified Type
 import qualified CoreUtils
 import qualified Type

-import qualified TcType
-import qualified Name

 import qualified Id
 import qualified Var
 import qualified VarSet
 import qualified Id
 import qualified Var
 import qualified VarSet

-import qualified NameSet

 import qualified CoreFVs
 import qualified CoreFVs

-import qualified CoreUtils

 import qualified MkCore
 import qualified MkCore

-import qualified HscTypes

 import Outputable ( showSDoc, ppr, nest )
 
 -- Local imports
 import CLasH.Normalize.NormalizeTypes
 import CLasH.Translator.TranslatorTypes
 import CLasH.Normalize.NormalizeTools
 import Outputable ( showSDoc, ppr, nest )
 
 -- Local imports
 import CLasH.Normalize.NormalizeTypes
 import CLasH.Translator.TranslatorTypes
 import CLasH.Normalize.NormalizeTools

-import CLasH.VHDL.VHDLTypes

 import qualified CLasH.Utils as Utils
 import CLasH.Utils.Core.CoreTools
 import CLasH.Utils.Core.BinderTools
 import qualified CLasH.Utils as Utils
 import CLasH.Utils.Core.CoreTools
 import CLasH.Utils.Core.BinderTools


@@ -235,7 +226,7 @@ letflattop = everywhere ("letflat", letflat)
 --------------------------------
 -- Remove empty (recursive) lets
 letremove, letremovetop :: Transform
 --------------------------------
 -- Remove empty (recursive) lets
 letremove, letremovetop :: Transform

-letremove (Let (Rec []) res) = change $ res
+letremove (Let (Rec []) res) = change res

 -- Leave all other expressions unchanged
 letremove expr = return expr
 -- Perform this transform everywhere
 -- Leave all other expressions unchanged
 letremove expr = return expr
 -- Perform this transform everywhere


@@ -435,7 +426,7 @@ casesimpl expr@(Case scrut b ty alts) = do
     -- Extract a complex expression, if possible. For this we check if any of
     -- the new list of bndrs are used by expr. We can't use free_vars here,
     -- since that looks at the old bndrs.
     -- Extract a complex expression, if possible. For this we check if any of
     -- the new list of bndrs are used by expr. We can't use free_vars here,
     -- since that looks at the old bndrs.

-    let uses_bndrs = not $ VarSet.isEmptyVarSet $ CoreFVs.exprSomeFreeVars (`elem` newbndrs) $ expr
+    let uses_bndrs = not $ VarSet.isEmptyVarSet $ CoreFVs.exprSomeFreeVars (`elem` newbndrs) expr

     (exprbinding_maybe, expr') <- doexpr expr uses_bndrs
     -- Create a new alternative
     let newalt = (con, newbndrs, expr')
     (exprbinding_maybe, expr') <- doexpr expr uses_bndrs
     -- Create a new alternative
     let newalt = (con, newbndrs, expr')


@@ -486,7 +477,7 @@ casesimpl expr@(Case scrut b ty alts) = do
             id <- Trans.lift $ mkBinderFor expr "caseval"
             -- We don't flag a change here, since casevalsimpl will do that above
             -- based on Just we return here.
             id <- Trans.lift $ mkBinderFor expr "caseval"
             -- We don't flag a change here, since casevalsimpl will do that above
             -- based on Just we return here.

-            return $ (Just (id, expr), Var id)
+            return (Just (id, expr), Var id)

           else
             -- Don't simplify anything else
             return (Nothing, expr)
           else
             -- Don't simplify anything else
             return (Nothing, expr)


@@ -584,7 +575,7 @@ argprop expr@(App _ _) | is_var fexpr = do
     doarg arg = do
       repr <- isRepr arg
       bndrs <- Trans.lift getGlobalBinders
     doarg arg = do
       repr <- isRepr arg
       bndrs <- Trans.lift getGlobalBinders

-      let interesting var = Var.isLocalVar var && (not $ var `elem` bndrs)
+      let interesting var = Var.isLocalVar var && (var `notElem` bndrs)

       if not repr && not (is_var arg && interesting (exprToVar arg)) && not (has_free_tyvars arg) 
         then do
           -- Propagate all complex arguments that are not representable, but not
       if not repr && not (is_var arg && interesting (exprToVar arg)) && not (has_free_tyvars arg) 
         then do
           -- Propagate all complex arguments that are not representable, but not


@@ -699,7 +690,7 @@ getNormalized ::
   CoreBndr -- ^ The function to get
   -> TranslatorSession CoreExpr -- The normalized function body
 
   CoreBndr -- ^ The function to get
   -> TranslatorSession CoreExpr -- The normalized function body
 

-getNormalized bndr = Utils.makeCached bndr tsNormalized $ do
+getNormalized bndr = Utils.makeCached bndr tsNormalized $

   if is_poly (Var bndr)
     then
       -- This should really only happen at the top level... TODO: Give
   if is_poly (Var bndr)
     then
       -- This should really only happen at the top level... TODO: Give


@@ -729,7 +720,7 @@ getBinding ::
   CoreBndr -- ^ The binder to get the expression for
   -> TranslatorSession CoreExpr -- ^ The value bound to the binder
 
   CoreBndr -- ^ The binder to get the expression for
   -> TranslatorSession CoreExpr -- ^ The value bound to the binder
 

-getBinding bndr = Utils.makeCached bndr tsBindings $ do
+getBinding bndr = Utils.makeCached bndr tsBindings $

   -- If the binding isn't in the "cache" (bindings map), then we can't create
   -- it out of thin air, so return an error.
   error $ "Normalize.getBinding: Unknown function requested: " ++ show bndr
   -- If the binding isn't in the "cache" (bindings map), then we can't create
   -- it out of thin air, so return an error.
   error $ "Normalize.getBinding: Unknown function requested: " ++ show bndr

diff --git a/cλash/CLasH/Normalize/NormalizeTools.hs b/cλash/CLasH/Normalize/NormalizeTools.hs
index 936a4ec1e834ec59c6cc49002f50f1878c544d6e..1995e38f9f69d44145bfec77ea264f4330ea9645 100644 (file)
--- a/cλash/CLasH/Normalize/NormalizeTools.hs
+++ b/cλash/CLasH/Normalize/NormalizeTools.hs
@@ -5,35 +5,27 @@
 module CLasH.Normalize.NormalizeTools where
 
 -- Standard modules
 module CLasH.Normalize.NormalizeTools where
 
 -- Standard modules

-import Debug.Trace
-import qualified List

 import qualified Data.Monoid as Monoid
 import qualified Data.Monoid as Monoid

-import qualified Data.Either as Either
-import qualified Control.Arrow as Arrow

 import qualified Control.Monad as Monad
 import qualified Control.Monad as Monad

-import qualified Control.Monad.Trans.State as State

 import qualified Control.Monad.Trans.Writer as Writer
 import qualified "transformers" Control.Monad.Trans as Trans
 import qualified Control.Monad.Trans.Writer as Writer
 import qualified "transformers" Control.Monad.Trans as Trans

-import qualified Data.Map as Map
-import Data.Accessor
-import Data.Accessor.Monad.Trans.State as MonadState
+import qualified Data.Accessor.Monad.Trans.State as MonadState
+-- import Debug.Trace

 
 -- GHC API
 import CoreSyn
 import qualified Name
 import qualified Id
 import qualified CoreSubst
 
 -- GHC API
 import CoreSyn
 import qualified Name
 import qualified Id
 import qualified CoreSubst

-import qualified CoreUtils

 import qualified Type
 import qualified Type

-import Outputable ( showSDoc, ppr, nest )
+-- import qualified CoreUtils
+-- import Outputable ( showSDoc, ppr, nest )

 
 -- Local imports
 import CLasH.Normalize.NormalizeTypes
 import CLasH.Translator.TranslatorTypes
 import CLasH.Utils
 
 -- Local imports
 import CLasH.Normalize.NormalizeTypes
 import CLasH.Translator.TranslatorTypes
 import CLasH.Utils

-import CLasH.Utils.Pretty

 import qualified CLasH.Utils.Core.CoreTools as CoreTools
 import qualified CLasH.Utils.Core.CoreTools as CoreTools

-import CLasH.VHDL.VHDLTypes

 import qualified CLasH.VHDL.VHDLTools as VHDLTools
 
 -- Apply the given transformation to all expressions in the given expression,
 import qualified CLasH.VHDL.VHDLTools as VHDLTools
 
 -- Apply the given transformation to all expressions in the given expression,


@@ -44,21 +36,21 @@ everywhere trans = applyboth (subeverywhere (everywhere trans)) trans
 -- Apply the first transformation, followed by the second transformation, and
 -- keep applying both for as long as expression still changes.
 applyboth :: Transform -> (String, Transform) -> Transform
 -- Apply the first transformation, followed by the second transformation, and
 -- keep applying both for as long as expression still changes.
 applyboth :: Transform -> (String, Transform) -> Transform

-applyboth first (name, second) expr  = do
+applyboth first (name, second) expr = do

   -- Apply the first
   expr' <- first expr
   -- Apply the second
   (expr'', changed) <- Writer.listen $ second expr'
   -- Apply the first
   expr' <- first expr
   -- Apply the second
   (expr'', changed) <- Writer.listen $ second expr'

-  if Monoid.getAny $
---        trace ("Trying to apply transform " ++ name ++ " to:\n" ++ showSDoc (nest 4 $ ppr expr') ++ "\nType: \n" ++ (showSDoc $ nest 4 $ ppr $ CoreUtils.exprType expr') ++ "\n") $
+  if Monoid.getAny
+        -- $ trace ("Trying to apply transform " ++ name ++ " to:\n" ++ showSDoc (nest 4 $ ppr expr') ++ "\nType: \n" ++ (showSDoc $ nest 4 $ ppr $ CoreUtils.exprType expr') ++ "\n") $

         changed 
     then 
         changed 
     then 

---      trace ("Applying transform " ++ name ++ " to:\n" ++ showSDoc (nest 4 $ ppr expr') ++ "\nType: \n" ++ (showSDoc $ nest 4 $ ppr $ CoreUtils.exprType expr') ++ "\n") $
---      trace ("Result of applying " ++ name ++ ":\n" ++ showSDoc (nest 4 $ ppr expr'') ++ "\n" ++ "Type: \n" ++ (showSDoc $ nest 4 $ ppr $ CoreUtils.exprType expr'') ++ "\n" ) $
-      applyboth first (name, second) $
+     -- trace ("Applying transform " ++ name ++ " to:\n" ++ showSDoc (nest 4 $ ppr expr') ++ "\nType: \n" ++ (showSDoc $ nest 4 $ ppr $ CoreUtils.exprType expr') ++ "\n") $
+     -- trace ("Result of applying " ++ name ++ ":\n" ++ showSDoc (nest 4 $ ppr expr'') ++ "\n" ++ "Type: \n" ++ (showSDoc $ nest 4 $ ppr $ CoreUtils.exprType expr'') ++ "\n" ) $
+      applyboth first (name, second)

         expr'' 
     else 
         expr'' 
     else 

---      trace ("No changes") $
+      -- trace ("No changes") $

       return expr''
 
 -- Apply the given transformation to all direct subexpressions (only), not the
       return expr''
 
 -- Apply the given transformation to all direct subexpressions (only), not the


@@ -193,7 +185,7 @@ isRepr tything = case CoreTools.getType tything of
 is_local_var :: CoreSyn.CoreExpr -> TranslatorSession Bool
 is_local_var (CoreSyn.Var v) = do
   bndrs <- getGlobalBinders
 is_local_var :: CoreSyn.CoreExpr -> TranslatorSession Bool
 is_local_var (CoreSyn.Var v) = do
   bndrs <- getGlobalBinders

-  return $ not $ v `elem` bndrs
+  return $ v `notElem` bndrs

 is_local_var _ = return False
 
 -- Is the given binder defined by the user?
 is_local_var _ = return False
 
 -- Is the given binder defined by the user?


@@ -201,7 +193,7 @@ isUserDefined :: CoreSyn.CoreBndr -> Bool
 -- System names are certain to not be user defined
 isUserDefined bndr | Name.isSystemName (Id.idName bndr) = False
 -- Check a list of typical compiler-defined names
 -- System names are certain to not be user defined
 isUserDefined bndr | Name.isSystemName (Id.idName bndr) = False
 -- Check a list of typical compiler-defined names

-isUserDefined bndr = not $ str `elem` compiler_names
+isUserDefined bndr = str `notElem` compiler_names

   where
     str = Name.getOccString bndr
     -- These are names of bindings usually generated by the compiler. For some
   where
     str = Name.getOccString bndr
     -- These are names of bindings usually generated by the compiler. For some

diff --git a/cλash/CLasH/Normalize/NormalizeTypes.hs b/cλash/CLasH/Normalize/NormalizeTypes.hs
index a13ca0f6f070b239da6f72f920beb6418b14f7c8..3affc870d75d0f2fa8a9655a7d93a561fbfd7892 100644 (file)
--- a/cλash/CLasH/Normalize/NormalizeTypes.hs
+++ b/cλash/CLasH/Normalize/NormalizeTypes.hs
@@ -1,24 +1,13 @@
-{-# LANGUAGE TemplateHaskell #-}

 module CLasH.Normalize.NormalizeTypes where
 
 module CLasH.Normalize.NormalizeTypes where
 

-

 -- Standard modules
 import qualified Control.Monad.Trans.Writer as Writer
 -- Standard modules
 import qualified Control.Monad.Trans.Writer as Writer

-import qualified Control.Monad.Trans.State as State

 import qualified Data.Monoid as Monoid
 import qualified Data.Monoid as Monoid

-import qualified Data.Accessor.Template
-import Data.Accessor
-import qualified Data.Map as Map
-import Debug.Trace

 
 -- GHC API
 
 -- GHC API

-import CoreSyn
-import qualified VarSet
-import Outputable ( Outputable, showSDoc, ppr )
+import qualified CoreSyn

 
 -- Local imports
 
 -- Local imports

-import CLasH.Utils.Core.CoreShow
-import CLasH.Utils.Pretty

 import CLasH.Translator.TranslatorTypes
 
 -- Wrap a writer around a TranslatorSession, to run a single transformation
 import CLasH.Translator.TranslatorTypes
 
 -- Wrap a writer around a TranslatorSession, to run a single transformation


@@ -26,4 +15,4 @@ import CLasH.Translator.TranslatorTypes
 type TransformMonad = Writer.WriterT Monoid.Any TranslatorSession
 
 -- | Transforms a CoreExpr and keeps track if it has changed.
 type TransformMonad = Writer.WriterT Monoid.Any TranslatorSession
 
 -- | Transforms a CoreExpr and keeps track if it has changed.

-type Transform = CoreExpr -> TransformMonad CoreExpr
+type Transform = CoreSyn.CoreExpr -> TransformMonad CoreSyn.CoreExpr

diff --git a/cλash/CLasH/Translator.hs b/cλash/CLasH/Translator.hs
index 16158d24df07fbbf441688a313cf3863cf47a9a5..04b7beb0900b14950dec9f5f0f00bc5454635666 100644 (file)
--- a/cλash/CLasH/Translator.hs
+++ b/cλash/CLasH/Translator.hs
@@ -1,5 +1,5 @@
 module CLasH.Translator 
 module CLasH.Translator 

-  ( -- makeVHDLStrings
+  (

    makeVHDLAnnotations
   ) where
 
    makeVHDLAnnotations
   ) where
 


@@ -12,25 +12,21 @@ import qualified Control.Monad.Trans.State as State
 import Text.PrettyPrint.HughesPJ (render)
 import Data.Accessor.Monad.Trans.State
 import qualified Data.Map as Map
 import Text.PrettyPrint.HughesPJ (render)
 import Data.Accessor.Monad.Trans.State
 import qualified Data.Map as Map

-import Debug.Trace

 
 -- GHC API
 import qualified CoreSyn
 
 -- GHC API
 import qualified CoreSyn

-import qualified GHC

 import qualified HscTypes
 import qualified UniqSupply
 
 -- VHDL Imports
 import qualified Language.VHDL.AST as AST
 import qualified HscTypes
 import qualified UniqSupply
 
 -- VHDL Imports
 import qualified Language.VHDL.AST as AST

-import qualified Language.VHDL.FileIO
+import qualified Language.VHDL.FileIO as FileIO

 import qualified Language.VHDL.Ppr as Ppr
 
 -- Local Imports
 import qualified Language.VHDL.Ppr as Ppr
 
 -- Local Imports

-import CLasH.Normalize

 import CLasH.Translator.TranslatorTypes
 import CLasH.Translator.Annotations
 import CLasH.Utils
 import CLasH.Translator.TranslatorTypes
 import CLasH.Translator.Annotations
 import CLasH.Utils

-import CLasH.Utils.Core.CoreTools

 import CLasH.Utils.GhcTools
 import CLasH.VHDL
 import CLasH.VHDL.VHDLTools
 import CLasH.Utils.GhcTools
 import CLasH.VHDL
 import CLasH.VHDL.VHDLTools


@@ -59,7 +55,7 @@ makeVHDLAnnotations ::
   FilePath      -- ^ The GHC Library Dir
   -> [FilePath] -- ^ The FileNames
   -> IO ()
   FilePath      -- ^ The GHC Library Dir
   -> [FilePath] -- ^ The FileNames
   -> IO ()

-makeVHDLAnnotations libdir filenames = do
+makeVHDLAnnotations libdir filenames =

   makeVHDL libdir filenames finder
     where
       finder = findSpec (hasCLasHAnnotation isTopEntity)
   makeVHDL libdir filenames finder
     where
       finder = findSpec (hasCLasHAnnotation isTopEntity)


@@ -83,7 +79,7 @@ makeVHDL libdir filenames finder = do
   let top_entity = head $ Maybe.catMaybes $ map (\(t, _, _) -> t) specs
   let dir = "./vhdl/" ++ (show top_entity) ++ "/"
   prepareDir dir
   let top_entity = head $ Maybe.catMaybes $ map (\(t, _, _) -> t) specs
   let dir = "./vhdl/" ++ (show top_entity) ++ "/"
   prepareDir dir

-  mapM (writeVHDL dir) vhdl
+  mapM_ (writeVHDL dir) vhdl

   return ()
 
 -- | Translate the specified entities in the given modules to VHDL.
   return ()
 
 -- | Translate the specified entities in the given modules to VHDL.


@@ -94,18 +90,17 @@ moduleToVHDL ::
   -> IO [(AST.VHDLId, AST.DesignFile)]
 moduleToVHDL env cores specs = do
   vhdl <- runTranslatorSession env $ do
   -> IO [(AST.VHDLId, AST.DesignFile)]
 moduleToVHDL env cores specs = do
   vhdl <- runTranslatorSession env $ do

-    let all_bindings = concat (map (\x -> CoreSyn.flattenBinds (HscTypes.cm_binds x)) cores)
+    let all_bindings = concatMap (\x -> CoreSyn.flattenBinds (HscTypes.cm_binds x)) cores

     -- Store the bindings we loaded
     tsBindings %= Map.fromList all_bindings
     -- Store the bindings we loaded
     tsBindings %= Map.fromList all_bindings

-    let all_initstates = concat (map (\x -> case x of (_, Nothing, _) -> []; (_, Just inits, _) -> inits) specs) 
+    let all_initstates = concatMap (\x -> case x of (_, Nothing, _) -> []; (_, Just inits, _) -> inits) specs 

     tsInitStates %= Map.fromList all_initstates
     test_binds <- catMaybesM $ Monad.mapM mkTest specs
     tsInitStates %= Map.fromList all_initstates
     test_binds <- catMaybesM $ Monad.mapM mkTest specs

-    mapM_ printAnns specs

     let topbinds = Maybe.catMaybes $ map (\(top, _, _) -> top) specs
     case topbinds of
     let topbinds = Maybe.catMaybes $ map (\(top, _, _) -> top) specs
     case topbinds of

-      []  -> error $ "Could not find top entity requested"
+      []  -> error "Could not find top entity requested"

       tops -> createDesignFiles (tops ++ test_binds)
       tops -> createDesignFiles (tops ++ test_binds)

-  mapM (putStr . render . Ppr.ppr . snd) vhdl
+  mapM_ (putStr . render . Ppr.ppr . snd) vhdl

   return vhdl
   where
     mkTest :: EntitySpec -> TranslatorSession (Maybe CoreSyn.CoreBndr)
   return vhdl
   where
     mkTest :: EntitySpec -> TranslatorSession (Maybe CoreSyn.CoreBndr)


@@ -115,9 +110,6 @@ moduleToVHDL env cores specs = do
     mkTest (Just top, _, Just input) = do
       bndr <- createTestbench Nothing cores input top
       return $ Just bndr
     mkTest (Just top, _, Just input) = do
       bndr <- createTestbench Nothing cores input top
       return $ Just bndr

-    printAnns :: EntitySpec -> TranslatorSession ()
-    printAnns (_, Nothing, _) = trace ("no anns found:\n\n") $ return ()
-    printAnns (_, (Just anns), _) = trace ("anns:\n\n" ++ show anns ++ "\n") $ return ()

 
 -- Run the given translator session. Generates a new UniqSupply for that
 -- session.
 
 -- Run the given translator session. Generates a new UniqSupply for that
 -- session.


@@ -154,6 +146,6 @@ writeVHDL dir (name, vhdl) = do
   -- Find the filename
   let fname = dir ++ (AST.fromVHDLId name) ++ ".vhdl"
   -- Write the file
   -- Find the filename
   let fname = dir ++ (AST.fromVHDLId name) ++ ".vhdl"
   -- Write the file

-  Language.VHDL.FileIO.writeDesignFile vhdl fname
+  FileIO.writeDesignFile vhdl fname

 
 -- vim: set ts=8 sw=2 sts=2 expandtab:
 
 -- vim: set ts=8 sw=2 sts=2 expandtab:

diff --git a/cλash/CLasH/Translator/Annotations.hs b/cλash/CLasH/Translator/Annotations.hs
index 6176438c1e7349f664324220f127b344d36c293e..2c875505c4b4091f2019d4f9af66fa3713599853 100644 (file)
--- a/cλash/CLasH/Translator/Annotations.hs
+++ b/cλash/CLasH/Translator/Annotations.hs
@@ -1,10 +1,10 @@
 {-# LANGUAGE DeriveDataTypeable #-}
 module CLasH.Translator.Annotations where
   
 {-# LANGUAGE DeriveDataTypeable #-}
 module CLasH.Translator.Annotations where
   

-import Language.Haskell.TH
+import qualified Language.Haskell.TH as TH

 import Data.Data
 
 import Data.Data
 

-data CLasHAnn = TopEntity | InitState Name | TestInput | TestCycles
+data CLasHAnn = TopEntity | InitState TH.Name | TestInput | TestCycles

   deriving (Show, Data, Typeable)
   
 isTopEntity :: CLasHAnn -> Bool
   deriving (Show, Data, Typeable)
   
 isTopEntity :: CLasHAnn -> Bool

diff --git a/cλash/CLasH/Translator/TranslatorTypes.hs b/cλash/CLasH/Translator/TranslatorTypes.hs
index 56c5c75a0324696d5f1d6b7d8aa0c934caa5295c..d8402567e14f16e27fdf547a7ab3d1a91a430286 100644 (file)
--- a/cλash/CLasH/Translator/TranslatorTypes.hs
+++ b/cλash/CLasH/Translator/TranslatorTypes.hs
@@ -1,8 +1,8 @@
+{-# LANGUAGE TemplateHaskell #-}

 --
 -- Simple module providing some types used by Translator. These are in a
 -- separate module to prevent circular dependencies in Pretty for example.
 --
 --
 -- Simple module providing some types used by Translator. These are in a
 -- separate module to prevent circular dependencies in Pretty for example.
 --

-{-# LANGUAGE TemplateHaskell #-}

 module CLasH.Translator.TranslatorTypes where
 
 -- Standard modules
 module CLasH.Translator.TranslatorTypes where
 
 -- Standard modules


@@ -18,12 +18,11 @@ import qualified Type
 import qualified HscTypes
 import qualified UniqSupply
 
 import qualified HscTypes
 import qualified UniqSupply
 

--- ForSyDe
+-- VHDL Imports

 import qualified Language.VHDL.AST as AST
 
 -- Local imports
 import CLasH.VHDL.VHDLTypes
 import qualified Language.VHDL.AST as AST
 
 -- Local imports
 import CLasH.VHDL.VHDLTypes

-import CLasH.Translator.Annotations

 
 -- | A specification of an entity we can generate VHDL for. Consists of the
 --   binder of the top level entity, an optional initial state and an optional
 
 -- | A specification of an entity we can generate VHDL for. Consists of the
 --   binder of the top level entity, an optional initial state and an optional


@@ -80,7 +79,7 @@ data TypeState = TypeState {
 }
 
 -- Derive accessors
 }
 
 -- Derive accessors

-$( Data.Accessor.Template.deriveAccessors ''TypeState )
+Data.Accessor.Template.deriveAccessors ''TypeState

 
 -- Define a session
 type TypeSession = State.State TypeState
 
 -- Define a session
 type TypeSession = State.State TypeState


@@ -97,7 +96,7 @@ data TranslatorState = TranslatorState {
 }
 
 -- Derive accessors
 }
 
 -- Derive accessors

-$( Data.Accessor.Template.deriveAccessors ''TranslatorState )
+Data.Accessor.Template.deriveAccessors ''TranslatorState

 
 type TranslatorSession = State.State TranslatorState
 
 
 type TranslatorSession = State.State TranslatorState
 

diff --git a/cλash/CLasH/Utils.hs b/cλash/CLasH/Utils.hs
index 51c6ebfc906281c79e74d5becc61fa289a3db143..41d7beee98a635083b2ad0c66d7aedbfc9403c46 100644 (file)
--- a/cλash/CLasH/Utils.hs
+++ b/cλash/CLasH/Utils.hs
@@ -3,14 +3,10 @@ module CLasH.Utils where
 -- Standard Imports
 import qualified Maybe
 import Data.Accessor
 -- Standard Imports
 import qualified Maybe
 import Data.Accessor

-import Data.Accessor.Monad.Trans.State as MonadState
+import qualified Data.Accessor.Monad.Trans.State as MonadState

 import qualified Data.Map as Map
 import qualified Control.Monad as Monad
 import qualified Control.Monad.Trans.State as State
 import qualified Data.Map as Map
 import qualified Control.Monad as Monad
 import qualified Control.Monad.Trans.State as State

-
--- GHC API
-
--- Local Imports

   
 -- Make a caching version of a stateful computatation.
 makeCached :: (Monad m, Ord k) =>
   
 -- Make a caching version of a stateful computatation.
 makeCached :: (Monad m, Ord k) =>

diff --git a/cλash/CLasH/Utils/Core/BinderTools.hs b/cλash/CLasH/Utils/Core/BinderTools.hs
index ef694746286b622a70dab4f98bbef36a247a264e..8d0751b5469b623137b25ecbb300826f67b42723 100644 (file)
--- a/cλash/CLasH/Utils/Core/BinderTools.hs
+++ b/cλash/CLasH/Utils/Core/BinderTools.hs
@@ -4,10 +4,10 @@
 module CLasH.Utils.Core.BinderTools where
 
 -- Standard modules
 module CLasH.Utils.Core.BinderTools where
 
 -- Standard modules

-import Data.Accessor.Monad.Trans.State as MonadState
+import qualified Data.Accessor.Monad.Trans.State as MonadState

 
 -- GHC API
 
 -- GHC API

-import CoreSyn
+import qualified CoreSyn

 import qualified Type
 import qualified UniqSupply
 import qualified Unique
 import qualified Type
 import qualified UniqSupply
 import qualified Unique


@@ -17,9 +17,6 @@ import qualified Var
 import qualified SrcLoc
 import qualified IdInfo
 import qualified CoreUtils
 import qualified SrcLoc
 import qualified IdInfo
 import qualified CoreUtils

-import qualified CoreSubst
-import qualified VarSet
-import qualified HscTypes

 
 -- Local imports
 import CLasH.Translator.TranslatorTypes
 
 -- Local imports
 import CLasH.Translator.TranslatorTypes


@@ -57,15 +54,15 @@ mkTypeVar str kind = do
 -- Creates a binder for the given expression with the given name. This
 -- works for both value and type level expressions, so it can return a Var or
 -- TyVar (which is just an alias for Var).
 -- Creates a binder for the given expression with the given name. This
 -- 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 -> TranslatorSession Var.Var
-mkBinderFor (Type ty) string = mkTypeVar string (Type.typeKind ty)
+mkBinderFor :: CoreSyn.CoreExpr -> String -> TranslatorSession Var.Var
+mkBinderFor (CoreSyn.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
 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

-mkReferenceTo :: Var.Var -> CoreExpr
-mkReferenceTo var | Var.isTyVar var = (Type $ Type.mkTyVarTy var)
-                  | otherwise       = (Var var)
+mkReferenceTo :: Var.Var -> CoreSyn.CoreExpr
+mkReferenceTo var | Var.isTyVar var = (CoreSyn.Type $ Type.mkTyVarTy var)
+                  | otherwise       = (CoreSyn.Var var)

 
 cloneVar :: Var.Var -> TranslatorSession Var.Var
 cloneVar v = do
 
 cloneVar :: Var.Var -> TranslatorSession Var.Var
 cloneVar v = do


@@ -77,7 +74,7 @@ cloneVar v = do
 -- Creates a new function with the same name as the given binder (but with a
 -- new unique) and with the given function body. Returns the new binder for
 -- this function.
 -- Creates a new function with the same name as the given binder (but with a
 -- new unique) and with the given function body. Returns the new binder for
 -- this function.

-mkFunction :: CoreBndr -> CoreExpr -> TranslatorSession CoreBndr
+mkFunction :: CoreSyn.CoreBndr -> CoreSyn.CoreExpr -> TranslatorSession CoreSyn.CoreBndr

 mkFunction bndr body = do
   let ty = CoreUtils.exprType body
   id <- cloneVar bndr
 mkFunction bndr body = do
   let ty = CoreUtils.exprType body
   id <- cloneVar bndr

diff --git a/cλash/CLasH/Utils/Core/CoreShow.hs b/cλash/CLasH/Utils/Core/CoreShow.hs
index 1db286ec6a7ff27d76826f77da891c4679333b33..ca2a7fba193094a06c30fe9a337918d6b80d1a55 100644 (file)
--- a/cλash/CLasH/Utils/Core/CoreShow.hs
+++ b/cλash/CLasH/Utils/Core/CoreShow.hs
@@ -1,23 +1,21 @@
 {-# LANGUAGE StandaloneDeriving,FlexibleInstances, UndecidableInstances, OverlappingInstances #-}
 {-# LANGUAGE StandaloneDeriving,FlexibleInstances, UndecidableInstances, OverlappingInstances #-}

-module CLasH.Utils.Core.CoreShow where
-
+--

 -- This module derives Show instances for CoreSyn types.
 -- This module derives Show instances for CoreSyn types.

+--
+module CLasH.Utils.Core.CoreShow where

 
 

+-- GHC API

 import qualified BasicTypes
 import qualified BasicTypes

-

 import qualified CoreSyn
 import qualified TypeRep
 import qualified TyCon
 import qualified CoreSyn
 import qualified TypeRep
 import qualified TyCon

-

 import qualified HsTypes
 import qualified HsExpr
 import qualified HsBinds
 import qualified SrcLoc
 import qualified RdrName
 import qualified HsTypes
 import qualified HsExpr
 import qualified HsBinds
 import qualified SrcLoc
 import qualified RdrName

-

 import Outputable ( Outputable, OutputableBndr, showSDoc, ppr)
 
 import Outputable ( Outputable, OutputableBndr, showSDoc, ppr)
 

-

 -- Derive Show for core expressions and binders, so we can see the actual
 -- structure.
 deriving instance (Show b) => Show (CoreSyn.Expr b)
 -- Derive Show for core expressions and binders, so we can see the actual
 -- structure.
 deriving instance (Show b) => Show (CoreSyn.Expr b)


@@ -38,7 +36,7 @@ deriving instance Show TyCon.SynTyConRhs
 -- Implement dummy shows, since deriving them will need loads of other shows
 -- as well.
 instance Show TypeRep.PredType where
 -- Implement dummy shows, since deriving them will need loads of other shows
 -- as well.
 instance Show TypeRep.PredType where

-  show t = "_PredType:(" ++ (showSDoc $ ppr t) ++ ")"
+  show t = "_PredType:(" ++ showSDoc (ppr t) ++ ")"

 instance Show TyCon.TyCon where
   show t | TyCon.isAlgTyCon t && not (TyCon.isTupleTyCon t) =
            showtc "AlgTyCon" ""
 instance Show TyCon.TyCon where
   show t | TyCon.isAlgTyCon t && not (TyCon.isTupleTyCon t) =
            showtc "AlgTyCon" ""


@@ -55,7 +53,7 @@ instance Show TyCon.TyCon where
          | TyCon.isSuperKindTyCon t =
            showtc "SuperKindTyCon" ""
          | otherwise = 
          | TyCon.isSuperKindTyCon t =
            showtc "SuperKindTyCon" ""
          | otherwise = 

-           "_Nonexistant tycon?:(" ++ (showSDoc $ ppr t) ++ ")_"
+           "_Nonexistant tycon?:(" ++ showSDoc (ppr t) ++ ")_"

       where
         showtc con extra = "(" ++ con ++ " {tyConName = " ++ name ++ extra ++ ", ...})"
         name = show (TyCon.tyConName t)
       where
         showtc con extra = "(" ++ con ++ " {tyConName = " ++ name ++ extra ++ ", ...})"
         name = show (TyCon.tyConName t)


@@ -79,4 +77,4 @@ instance Show (HsExpr.GRHSs id) where
 
 
 instance (Outputable x) => Show x where
 
 
 instance (Outputable x) => Show x where

-  show x = "__" ++  (showSDoc $ ppr x) ++ "__"
+  show x = "__" ++ showSDoc (ppr x) ++ "__"

diff --git a/cλash/CLasH/Utils/Core/CoreTools.hs b/cλash/CLasH/Utils/Core/CoreTools.hs
index acc2fa630c416a32f6a99a15c0df18281b6526da..19c12700aa86d23709589687e779d70b82fc23f2 100644 (file)
--- a/cλash/CLasH/Utils/Core/CoreTools.hs
+++ b/cλash/CLasH/Utils/Core/CoreTools.hs
@@ -7,7 +7,7 @@ module CLasH.Utils.Core.CoreTools where
 
 --Standard modules
 import qualified Maybe
 
 --Standard modules
 import qualified Maybe

-import System.IO.Unsafe
+import qualified System.IO.Unsafe

 
 -- GHC API
 import qualified GHC
 
 -- GHC API
 import qualified GHC


@@ -15,30 +15,23 @@ import qualified Type
 import qualified TcType
 import qualified HsExpr
 import qualified HsTypes
 import qualified TcType
 import qualified HsExpr
 import qualified HsTypes

-import qualified HsBinds

 import qualified HscTypes
 import qualified HscTypes

-import qualified RdrName

 import qualified Name
 import qualified Name

-import qualified OccName
-import qualified Type

 import qualified Id
 import qualified TyCon
 import qualified DataCon
 import qualified TysWiredIn
 import qualified Id
 import qualified TyCon
 import qualified DataCon
 import qualified TysWiredIn

-import qualified Bag

 import qualified DynFlags
 import qualified SrcLoc
 import qualified CoreSyn
 import qualified Var
 import qualified IdInfo
 import qualified VarSet
 import qualified DynFlags
 import qualified SrcLoc
 import qualified CoreSyn
 import qualified Var
 import qualified IdInfo
 import qualified VarSet

-import qualified Unique

 import qualified CoreUtils
 import qualified CoreFVs
 import qualified Literal
 import qualified MkCore
 import qualified VarEnv
 import qualified CoreUtils
 import qualified CoreFVs
 import qualified Literal
 import qualified MkCore
 import qualified VarEnv

-import qualified Literal

 
 -- Local imports
 import CLasH.Translator.TranslatorTypes
 
 -- Local imports
 import CLasH.Translator.TranslatorTypes


@@ -74,9 +67,8 @@ eval_tfp_int env ty =
 
 normalise_tfp_int :: HscTypes.HscEnv -> Type.Type -> Type.Type
 normalise_tfp_int env ty =
 
 normalise_tfp_int :: HscTypes.HscEnv -> Type.Type -> Type.Type
 normalise_tfp_int env ty =

-   unsafePerformIO $ do
-     nty <- normaliseType env ty
-     return nty
+   System.IO.Unsafe.unsafePerformIO $
+     normaliseType env ty

 
 -- | Get the width of a SizedWord type
 -- sized_word_len :: HscTypes.HscEnv -> Type.Type -> Int
 
 -- | Get the width of a SizedWord type
 -- sized_word_len :: HscTypes.HscEnv -> Type.Type -> Int


@@ -278,7 +270,7 @@ reduceCoreListToHsList _ _ = return []
 
 -- Is the given var the State data constructor?
 isStateCon :: Var.Var -> Bool
 
 -- Is the given var the State data constructor?
 isStateCon :: Var.Var -> Bool

-isStateCon var = do
+isStateCon var =

   -- See if it is a DataConWrapId (not DataConWorkId, since State is a
   -- newtype).
   case Id.idDetails var of
   -- See if it is a DataConWrapId (not DataConWorkId, since State is a
   -- newtype).
   case Id.idDetails var of


@@ -390,7 +382,7 @@ genUniques' subst (CoreSyn.Let (CoreSyn.NonRec bndr bound) res) = do
 genUniques' subst (CoreSyn.Let (CoreSyn.Rec binds) res) = do
   -- Make each of the binders unique
   (subst', bndrs') <- mapAccumLM genUnique subst (map fst binds)
 genUniques' subst (CoreSyn.Let (CoreSyn.Rec binds) res) = do
   -- Make each of the binders unique
   (subst', bndrs') <- mapAccumLM genUnique subst (map fst binds)

-  bounds' <- mapM (genUniques' subst') (map snd binds)
+  bounds' <- mapM (genUniques' subst' . snd) binds

   res' <- genUniques' subst' res
   let binds' = zip bndrs' bounds'
   return $ CoreSyn.Let (CoreSyn.Rec binds') res'
   res' <- genUniques' subst' res
   let binds' = zip bndrs' bounds'
   return $ CoreSyn.Let (CoreSyn.Rec binds') res'

diff --git a/cλash/CLasH/Utils/GhcTools.hs b/cλash/CLasH/Utils/GhcTools.hs
index c11b5486ffc0424aaaf6c3ca60084fc1fe8ce623..fc63ac4e9560079185caaa13bba32df694f88d61 100644 (file)
--- a/cλash/CLasH/Utils/GhcTools.hs
+++ b/cλash/CLasH/Utils/GhcTools.hs
@@ -29,8 +29,8 @@ import CLasH.Utils
 listBindings :: FilePath -> [FilePath] -> IO [()]
 listBindings libdir filenames = do
   (cores,_,_) <- loadModules libdir filenames Nothing
 listBindings :: FilePath -> [FilePath] -> IO [()]
 listBindings libdir filenames = do
   (cores,_,_) <- loadModules libdir filenames Nothing

-  let binds = concat $ map (CoreSyn.flattenBinds . HscTypes.cm_binds) cores
-  mapM (listBinding) binds
+  let binds = concatMap (CoreSyn.flattenBinds . HscTypes.cm_binds) cores
+  mapM listBinding binds

 
 listBinding :: (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -> IO ()
 listBinding (b, e) = do
 
 listBinding :: (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -> IO ()
 listBinding (b, e) = do


@@ -51,7 +51,7 @@ listBind :: FilePath -> [FilePath] -> String -> IO ()
 listBind libdir filenames name = do
   (cores,_,_) <- loadModules libdir filenames Nothing
   bindings <- concatM $ mapM (findBinder (hasVarName name)) cores
 listBind libdir filenames name = do
   (cores,_,_) <- loadModules libdir filenames Nothing
   bindings <- concatM $ mapM (findBinder (hasVarName name)) cores

-  mapM listBinding bindings
+  mapM_ listBinding bindings

   return ()
 
 -- Change a DynFlag from within the Ghc monad. Strangely enough there seems to
   return ()
 
 -- Change a DynFlag from within the Ghc monad. Strangely enough there seems to


@@ -71,7 +71,7 @@ setDynFlag dflag = do
 -- just return an IO monad when they are evaluated).
 unsafeRunGhc :: FilePath -> GHC.Ghc a -> a
 unsafeRunGhc libDir m =
 -- just return an IO monad when they are evaluated).
 unsafeRunGhc :: FilePath -> GHC.Ghc a -> a
 unsafeRunGhc libDir m =

-  System.IO.Unsafe.unsafePerformIO $ do
+  System.IO.Unsafe.unsafePerformIO $

       GHC.runGhc (Just libDir) $ do
         dflags <- GHC.getSessionDynFlags
         GHC.setSessionDynFlags dflags
       GHC.runGhc (Just libDir) $ do
         dflags <- GHC.getSessionDynFlags
         GHC.setSessionDynFlags dflags


@@ -87,7 +87,7 @@ loadModules ::
         , [EntitySpec]
         ) -- ^ ( The loaded modules, the resulting ghc environment, the entities to build)
 loadModules libdir filenames finder =
         , [EntitySpec]
         ) -- ^ ( The loaded modules, the resulting ghc environment, the entities to build)
 loadModules libdir filenames finder =

-  GHC.defaultErrorHandler DynFlags.defaultDynFlags $ do
+  GHC.defaultErrorHandler DynFlags.defaultDynFlags $

     GHC.runGhc (Just libdir) $ do
       dflags <- GHC.getSessionDynFlags
       GHC.setSessionDynFlags dflags
     GHC.runGhc (Just libdir) $ do
       dflags <- GHC.getSessionDynFlags
       GHC.setSessionDynFlags dflags


@@ -129,7 +129,7 @@ findExprs criteria core = do
   binders <- findBinder criteria core
   case binders of
     [] -> return Nothing
   binders <- findBinder criteria core
   case binders of
     [] -> return Nothing

-    bndrs -> return $ Just $ (map snd bndrs)
+    bndrs -> return $ Just (map snd bndrs)

 
 findExpr ::
   Monad m =>
 
 findExpr ::
   Monad m =>


@@ -162,8 +162,7 @@ findBinder ::
   -> m [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)] -- ^ The binders to meet the criteria
 findBinder criteria core = do
   let binds = CoreSyn.flattenBinds $ HscTypes.cm_binds core
   -> m [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)] -- ^ The binders to meet the criteria
 findBinder criteria core = do
   let binds = CoreSyn.flattenBinds $ HscTypes.cm_binds core

-  critbinds <- Monad.filterM (criteria . fst) binds
-  return critbinds
+  Monad.filterM (criteria . fst) binds

 
 -- | Determine if a binder has an Annotation meeting a certain criteria
 isCLasHAnnotation ::
 
 -- | Determine if a binder has an Annotation meeting a certain criteria
 isCLasHAnnotation ::


@@ -196,7 +195,7 @@ hasVarName ::
   String        -- ^ The name the binder has to have
   -> Var.Var    -- ^ The Binder
   -> m Bool     -- ^ Indicate if the binder has the name
   String        -- ^ The name the binder has to have
   -> Var.Var    -- ^ The Binder
   -> m Bool     -- ^ Indicate if the binder has the name

-hasVarName lookfor bind = return $ lookfor == (Name.occNameString $ Name.nameOccName $ Name.getName bind)
+hasVarName lookfor bind = return $ lookfor == Name.occNameString (Name.nameOccName $ Name.getName bind)

 
 
 findInitStates ::
 
 
 findInitStates ::

diff --git a/cλash/CLasH/Utils/HsTools.hs b/cλash/CLasH/Utils/HsTools.hs
index ca20441cc706a360b17cc1b53c40fff89fde77a2..c08bad7b4fe1a0b133957cee6addf91c359d1eb9 100644 (file)
--- a/cλash/CLasH/Utils/HsTools.hs
+++ b/cλash/CLasH/Utils/HsTools.hs
@@ -1,4 +1,3 @@
-{-# LANGUAGE ViewPatterns #-}

 module CLasH.Utils.HsTools where
 
 -- Standard modules
 module CLasH.Utils.HsTools where
 
 -- Standard modules


@@ -33,29 +32,20 @@ import qualified TcEnv
 import qualified TcSimplify
 import qualified TcTyFuns
 import qualified Desugar
 import qualified TcSimplify
 import qualified TcTyFuns
 import qualified Desugar

-import qualified InstEnv
-import qualified FamInstEnv

 import qualified PrelNames
 import qualified Module
 import qualified OccName
 import qualified RdrName
 import qualified Name
 import qualified PrelNames
 import qualified Module
 import qualified OccName
 import qualified RdrName
 import qualified Name

-import qualified TysWiredIn

 import qualified SrcLoc
 import qualified LoadIface
 import qualified BasicTypes
 import qualified SrcLoc
 import qualified LoadIface
 import qualified BasicTypes

-import qualified Bag

 -- Core representation and handling
 import qualified CoreSyn
 import qualified Id
 import qualified Type
 import qualified TyCon
 
 -- Core representation and handling
 import qualified CoreSyn
 import qualified Id
 import qualified Type
 import qualified TyCon
 

-
--- Local imports
-import CLasH.Utils.GhcTools
-import CLasH.Utils.Core.CoreShow
-

 -- | Translate a HsExpr to a Core expression. This does renaming, type
 -- checking, simplification of class instances and desugaring. The result is
 -- a let expression that holds the given expression and a number of binds that
 -- | Translate a HsExpr to a Core expression. This does renaming, type
 -- checking, simplification of class instances and desugaring. The result is
 -- a let expression that holds the given expression and a number of binds that


@@ -96,15 +86,14 @@ toCore expr = do
         tc_expr
   -- Desugar the expression, resulting in core.
   let rdr_env  = HscTypes.ic_rn_gbl_env icontext
         tc_expr
   -- Desugar the expression, resulting in core.
   let rdr_env  = HscTypes.ic_rn_gbl_env icontext

-  desugar_expr <- HscTypes.ioMsgMaybe $ Desugar.deSugarExpr env PrelNames.iNTERACTIVE rdr_env HscTypes.emptyTypeEnv letexpr
+  HscTypes.ioMsgMaybe $ Desugar.deSugarExpr env PrelNames.iNTERACTIVE rdr_env HscTypes.emptyTypeEnv letexpr

 
 

-  return desugar_expr

 
 -- | Create an Id from a RdrName. Might not work for DataCons...
 mkId :: RdrName.RdrName -> GHC.Ghc Id.Id
 mkId rdr_name = do
   env <- GHC.getSession
 
 -- | Create an Id from a RdrName. Might not work for DataCons...
 mkId :: RdrName.RdrName -> GHC.Ghc Id.Id
 mkId rdr_name = do
   env <- GHC.getSession

-  id <- HscTypes.ioMsgMaybe $ MonadUtils.liftIO $ 
+  HscTypes.ioMsgMaybe $ MonadUtils.liftIO $ 

     -- Translage the TcRn (typecheck-rename) monad in an IO monad
     TcRnMonad.initTcPrintErrors env PrelNames.iNTERACTIVE $ 
       -- Automatically import all available modules, so fully qualified names
     -- Translage the TcRn (typecheck-rename) monad in an IO monad
     TcRnMonad.initTcPrintErrors env PrelNames.iNTERACTIVE $ 
       -- Automatically import all available modules, so fully qualified names


@@ -119,7 +108,6 @@ mkId rdr_name = do
         -- Note that tcLookupId doesn't seem to work for DataCons. See source for
         -- tcLookupId to find out.
         TcEnv.tcLookupId name 
         -- Note that tcLookupId doesn't seem to work for DataCons. See source for
         -- tcLookupId to find out.
         TcEnv.tcLookupId name 

-  return id

 
 normaliseType ::
   HscTypes.HscEnv
 
 normaliseType ::
   HscTypes.HscEnv


@@ -147,7 +135,7 @@ coreToHsType ty = case Type.splitTyConApp_maybe ty of
       occ_name = Name.nameOccName tycon_name
       tycon_rdrname = RdrName.mkRdrQual mod_name occ_name
       tycon_ty = SrcLoc.noLoc $ HsTypes.HsTyVar tycon_rdrname
       occ_name = Name.nameOccName tycon_name
       tycon_rdrname = RdrName.mkRdrQual mod_name occ_name
       tycon_ty = SrcLoc.noLoc $ HsTypes.HsTyVar tycon_rdrname

-  Nothing -> error $ "HsTools.coreToHsType Cannot translate non-tycon type"
+  Nothing -> error "HsTools.coreToHsType Cannot translate non-tycon type"

 
 -- | Evaluate a CoreExpr and return its value. For this to work, the caller
 --   should already know the result type for sure, since the result value is
 
 -- | Evaluate a CoreExpr and return its value. For this to work, the caller
 --   should already know the result type for sure, since the result value is

diff --git a/cλash/CLasH/Utils/Pretty.hs b/cλash/CLasH/Utils/Pretty.hs
index 56b3aaf6238d536745bbeaa50dedf77a8be86cb7..df78ad9ca9fea259af4ad00f857d210c6391abd3 100644 (file)
--- a/cλash/CLasH/Utils/Pretty.hs
+++ b/cλash/CLasH/Utils/Pretty.hs
@@ -1,21 +1,19 @@
 module CLasH.Utils.Pretty (prettyShow, pprString, pprStringDebug) where
 
 module CLasH.Utils.Pretty (prettyShow, pprString, pprStringDebug) where
 

-
+-- Standard imports

 import qualified Data.Map as Map
 import qualified Data.Map as Map

-import qualified Data.Foldable as Foldable
-import qualified List
+import Text.PrettyPrint.HughesPJClass

 
 

+-- GHC API

 import qualified CoreSyn
 import qualified CoreSyn

-import qualified Module
-import qualified HscTypes
-import Text.PrettyPrint.HughesPJClass

 import Outputable ( showSDoc, showSDocDebug, ppr, Outputable, OutputableBndr)
 
 import Outputable ( showSDoc, showSDocDebug, ppr, Outputable, OutputableBndr)
 

+-- VHDL Imports 

 import qualified Language.VHDL.Ppr as Ppr
 import qualified Language.VHDL.AST as AST
 import qualified Language.VHDL.AST.Ppr
 
 import qualified Language.VHDL.Ppr as Ppr
 import qualified Language.VHDL.AST as AST
 import qualified Language.VHDL.AST.Ppr
 

-import CLasH.Translator.TranslatorTypes
+-- Local imports

 import CLasH.VHDL.VHDLTypes
 import CLasH.Utils.Core.CoreShow
 
 import CLasH.VHDL.VHDLTypes
 import CLasH.Utils.Core.CoreShow
 

diff --git a/cλash/CLasH/VHDL.hs b/cλash/CLasH/VHDL.hs
index 21671adedef95da3bccd4f64e204486e43b620b0..56342fc2ce7df52d35d1caef448fea5381282ee4 100644 (file)
--- a/cλash/CLasH/VHDL.hs
+++ b/cλash/CLasH/VHDL.hs
@@ -6,38 +6,22 @@ module CLasH.VHDL where
 -- Standard modules
 import qualified Data.Map as Map
 import qualified Maybe
 -- Standard modules
 import qualified Data.Map as Map
 import qualified Maybe

-import qualified Control.Monad as Monad

 import qualified Control.Arrow as Arrow
 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

-import Data.Accessor.Monad.Trans.State as MonadState
-import Debug.Trace
+import qualified Data.Accessor.Monad.Trans.State as MonadState

 
 

--- ForSyDe
+-- VHDL Imports

 import qualified Language.VHDL.AST as AST
 
 -- GHC API
 import qualified Language.VHDL.AST as AST
 
 -- GHC API

-import CoreSyn
---import qualified Type
-import qualified Name
-import qualified Var
-import qualified IdInfo
-import qualified TyCon
-import qualified DataCon
---import qualified CoreSubst
-import qualified CoreUtils
-import Outputable ( showSDoc, ppr )
+import qualified CoreSyn

 
 -- Local imports
 import CLasH.Translator.TranslatorTypes
 import CLasH.VHDL.VHDLTypes
 import CLasH.VHDL.VHDLTools
 
 -- Local imports
 import CLasH.Translator.TranslatorTypes
 import CLasH.VHDL.VHDLTypes
 import CLasH.VHDL.VHDLTools

-import CLasH.Utils.Pretty
-import CLasH.Utils.Core.CoreTools

 import CLasH.VHDL.Constants
 import CLasH.VHDL.Generate
 import CLasH.VHDL.Constants
 import CLasH.VHDL.Generate

-import CLasH.VHDL.Testbench

 
 createDesignFiles ::
   [CoreSyn.CoreBndr] -- ^ Top binders
 
 createDesignFiles ::
   [CoreSyn.CoreBndr] -- ^ Top binders


@@ -83,16 +67,16 @@ createTypesPackage ::
  
 createTypesPackage = do
   tyfuns <- MonadState.get (tsType .> tsTypeFuns)
  
 createTypesPackage = do
   tyfuns <- MonadState.get (tsType .> tsTypeFuns)

-  let tyfun_decls = mkBuiltInShow ++ (map snd $ Map.elems tyfuns)
+  let tyfun_decls = mkBuiltInShow ++ map snd (Map.elems tyfuns)

   ty_decls_maybes <- MonadState.get (tsType .> tsTypeDecls)
   let ty_decls = Maybe.catMaybes ty_decls_maybes
   let subProgSpecs = map (\(AST.SubProgBody spec _ _) -> AST.PDISS spec) tyfun_decls
   let type_package_dec = AST.LUPackageDec $ AST.PackageDec (mkVHDLBasicId "types") ([tfvec_index_decl] ++ ty_decls ++ subProgSpecs)
   let type_package_body = AST.LUPackageBody $ AST.PackageBody typesId tyfun_decls
   ty_decls_maybes <- MonadState.get (tsType .> tsTypeDecls)
   let ty_decls = Maybe.catMaybes ty_decls_maybes
   let subProgSpecs = map (\(AST.SubProgBody spec _ _) -> AST.PDISS spec) tyfun_decls
   let type_package_dec = AST.LUPackageDec $ AST.PackageDec (mkVHDLBasicId "types") ([tfvec_index_decl] ++ ty_decls ++ subProgSpecs)
   let type_package_body = AST.LUPackageBody $ AST.PackageBody typesId tyfun_decls

-  return $ (mkVHDLBasicId "types", AST.DesignFile ieee_context [type_package_dec, type_package_body])
+  return (mkVHDLBasicId "types", AST.DesignFile ieee_context [type_package_dec, type_package_body])

   where
     tfvec_index_decl = AST.PDISD $ AST.SubtypeDec tfvec_indexTM tfvec_index_def
   where
     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) (AST.NSimple $ 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)
 
 -- Create a use foo.bar.all statement. Takes a list of components in the used
     tfvec_index_def = AST.SubtypeIn integerTM (Just tfvec_range)
 
 -- Create a use foo.bar.all statement. Takes a list of components in the used

diff --git a/cλash/CLasH/VHDL/Constants.hs b/cλash/CLasH/VHDL/Constants.hs
index 8c96148cec95b23c56a6e88cacf52ef82ed17c36..22bf14aabaac4e047905c5b8d7cf916fc9cc6768 100644 (file)
--- a/cλash/CLasH/VHDL/Constants.hs
+++ b/cλash/CLasH/VHDL/Constants.hs
@@ -1,5 +1,6 @@
 module CLasH.VHDL.Constants where
 module CLasH.VHDL.Constants where

-  
+
+-- VHDL Imports  

 import qualified Language.VHDL.AST as AST
 
 --------------
 import qualified Language.VHDL.AST as AST
 
 --------------

diff --git a/cλash/CLasH/VHDL/Generate.hs b/cλash/CLasH/VHDL/Generate.hs
index 4b24b576e89ca597a8c4b85b8bb551682d63e7fa..0141db45c001ab0d38f9be2a8762d5b2a6684744 100644 (file)
--- a/cλash/CLasH/VHDL/Generate.hs
+++ b/cλash/CLasH/VHDL/Generate.hs
@@ -6,10 +6,9 @@ import qualified Data.Map as Map
 import qualified Control.Monad as Monad
 import qualified Maybe
 import qualified Data.Either as Either
 import qualified Control.Monad as Monad
 import qualified Maybe
 import qualified Data.Either as Either

-import Data.Accessor.Monad.Trans.State as MonadState
-import Debug.Trace
+import qualified Data.Accessor.Monad.Trans.State as MonadState

 
 

--- ForSyDe
+-- VHDL Imports

 import qualified Language.VHDL.AST as AST
 
 -- GHC API
 import qualified Language.VHDL.AST as AST
 
 -- GHC API


@@ -27,7 +26,7 @@ import CLasH.Translator.TranslatorTypes
 import CLasH.VHDL.Constants
 import CLasH.VHDL.VHDLTypes
 import CLasH.VHDL.VHDLTools
 import CLasH.VHDL.Constants
 import CLasH.VHDL.VHDLTypes
 import CLasH.VHDL.VHDLTools

-import CLasH.Utils as Utils
+import CLasH.Utils

 import CLasH.Utils.Core.CoreTools
 import CLasH.Utils.Pretty
 import qualified CLasH.Normalize as Normalize
 import CLasH.Utils.Core.CoreTools
 import CLasH.Utils.Pretty
 import qualified CLasH.Normalize as Normalize


@@ -41,7 +40,7 @@ getEntity ::
   CoreSyn.CoreBndr
   -> TranslatorSession Entity -- ^ The resulting entity
 
   CoreSyn.CoreBndr
   -> TranslatorSession Entity -- ^ The resulting entity
 

-getEntity fname = Utils.makeCached fname tsEntities $ do
+getEntity fname = makeCached fname tsEntities $ do

       expr <- Normalize.getNormalized fname
       -- Split the normalized expression
       let (args, binds, res) = Normalize.splitNormalized expr
       expr <- Normalize.getNormalized fname
       -- Split the normalized expression
       let (args, binds, res) = Normalize.splitNormalized expr


@@ -109,7 +108,7 @@ getArchitecture ::
   -> TranslatorSession (Architecture, [CoreSyn.CoreBndr])
   -- ^ The architecture for this function
 
   -> TranslatorSession (Architecture, [CoreSyn.CoreBndr])
   -- ^ The architecture for this function
 

-getArchitecture fname = Utils.makeCached fname tsArchitectures $ do
+getArchitecture fname = makeCached fname tsArchitectures $ do

   expr <- Normalize.getNormalized fname
   -- Split the normalized expression
   let (args, binds, res) = Normalize.splitNormalized expr
   expr <- Normalize.getNormalized fname
   -- Split the normalized expression
   let (args, binds, res) = Normalize.splitNormalized expr


@@ -122,7 +121,7 @@ getArchitecture fname = Utils.makeCached fname tsArchitectures $ do
   -- for the output port (that will already have an output port declared in
   -- the entity).
   sig_dec_maybes <- mapM (mkSigDec . fst) (filter ((/=res).fst) binds)
   -- for the output port (that will already have an output port declared in
   -- the entity).
   sig_dec_maybes <- mapM (mkSigDec . fst) (filter ((/=res).fst) binds)

-  let sig_decs = Maybe.catMaybes $ sig_dec_maybes
+  let sig_decs = Maybe.catMaybes sig_dec_maybes

   -- Process each bind, resulting in info about state variables and concurrent
   -- statements.
   (state_vars, sms) <- Monad.mapAndUnzipM dobind binds
   -- Process each bind, resulting in info about state variables and concurrent
   -- statements.
   (state_vars, sms) <- Monad.mapAndUnzipM dobind binds


@@ -184,8 +183,8 @@ mkStateProcSm (old, new, res) = do
   let resvaldec = AST.BDISD $ AST.SigDec resvalid type_mark_res Nothing
   let reswform  = AST.Wform [AST.WformElem (AST.PrimName $ AST.NSimple resvalid) Nothing]
   let res_assign = AST.SigAssign (varToVHDLName old) reswform
   let resvaldec = AST.BDISD $ AST.SigDec resvalid type_mark_res Nothing
   let reswform  = AST.Wform [AST.WformElem (AST.PrimName $ AST.NSimple resvalid) Nothing]
   let res_assign = AST.SigAssign (varToVHDLName old) reswform

-  let blocklabel       = mkVHDLBasicId $ "state"
-  let statelabel  = mkVHDLBasicId $ "stateupdate"
+  let blocklabel       = mkVHDLBasicId "state"
+  let statelabel  = mkVHDLBasicId "stateupdate"

   let rising_edge = AST.NSimple $ mkVHDLBasicId "rising_edge"
   let wform       = AST.Wform [AST.WformElem (AST.PrimName $ varToVHDLName new) Nothing]
   let clk_assign      = AST.SigAssign (varToVHDLName old) wform
   let rising_edge = AST.NSimple $ mkVHDLBasicId "rising_edge"
   let wform       = AST.Wform [AST.WformElem (AST.PrimName $ varToVHDLName new) Nothing]
   let clk_assign      = AST.SigAssign (varToVHDLName old) wform


@@ -220,7 +219,7 @@ mkConcSm (bndr, CoreSyn.Cast expr ty) = mkConcSm (bndr, expr)
 -- Simple a = b assignments are just like applications, but without arguments.
 -- We can't just generate an unconditional assignment here, since b might be a
 -- top level binding (e.g., a function with no arguments).
 -- Simple a = b assignments are just like applications, but without arguments.
 -- We can't just generate an unconditional assignment here, since b might be a
 -- top level binding (e.g., a function with no arguments).

-mkConcSm (bndr, CoreSyn.Var v) = do
+mkConcSm (bndr, CoreSyn.Var v) =

   genApplication (Left bndr) v []
 
 mkConcSm (bndr, app@(CoreSyn.App _ _))= do
   genApplication (Left bndr) v []
 
 mkConcSm (bndr, app@(CoreSyn.App _ _))= do


@@ -247,7 +246,7 @@ mkConcSm (bndr, expr@(CoreSyn.Case (CoreSyn.Var scrut) b ty [alt]))
               let sel_name = varToVHDLName scrut
               let sel_expr = AST.PrimName sel_name
               return ([mkUncondAssign (Left bndr) sel_expr], [])
               let sel_name = varToVHDLName scrut
               let sel_expr = AST.PrimName sel_name
               return ([mkUncondAssign (Left bndr) sel_expr], [])

-            otherwise -> do
+            otherwise ->

               case htypeScrt of
                 Right (AggrType _ _) -> do
                   labels <- MonadState.lift tsType $ getFieldLabels (Id.idType scrut)
               case htypeScrt of
                 Right (AggrType _ _) -> do
                   labels <- MonadState.lift tsType $ getFieldLabels (Id.idType scrut)


@@ -309,7 +308,7 @@ argToVHDLExpr (Left expr) = MonadState.lift tsType $ do
     Just _ -> do
       vhdl_expr <- varToVHDLExpr $ exprToVar expr
       return $ Just vhdl_expr
     Just _ -> do
       vhdl_expr <- varToVHDLExpr $ exprToVar expr
       return $ Just vhdl_expr

-    Nothing -> return $ Nothing
+    Nothing -> return Nothing

 
 argToVHDLExpr (Right expr) = return $ Just expr
 
 
 argToVHDLExpr (Right expr) = return $ Just expr
 


@@ -342,10 +341,9 @@ genLitArgs wrap dst func args = do
   hscenv <- MonadState.lift tsType $ MonadState.get tsHscEnv
   let (exprargs, []) = Either.partitionEithers args
   -- FIXME: Check if we were passed an CoreSyn.App
   hscenv <- MonadState.lift tsType $ MonadState.get tsHscEnv
   let (exprargs, []) = Either.partitionEithers args
   -- FIXME: Check if we were passed an CoreSyn.App

-  let litargs = concat (map (getLiterals hscenv) exprargs)
+  let litargs = concatMap (getLiterals hscenv) exprargs

   let args' = map exprToLit litargs
   let args' = map exprToLit litargs

-  concsms <- wrap dst func args'
-  return concsms    
+  wrap dst func args'   

 
 -- | A function to wrap a builder-like function that produces an expression
 -- and expects it to be assigned to the destination.
 
 -- | A function to wrap a builder-like function that produces an expression
 -- and expects it to be assigned to the destination.


@@ -354,7 +352,7 @@ genExprRes ::
   -> ((Either CoreSyn.CoreBndr AST.VHDLName) -> func -> [arg] -> TranslatorSession [AST.ConcSm])
 genExprRes wrap dst func args = do
   expr <- wrap dst func args
   -> ((Either CoreSyn.CoreBndr AST.VHDLName) -> func -> [arg] -> TranslatorSession [AST.ConcSm])
 genExprRes wrap dst func args = do
   expr <- wrap dst func args

-  return $ [mkUncondAssign dst expr]
+  return [mkUncondAssign dst expr]

 
 -- | Generate a binary operator application. The first argument should be a
 -- constructor from the AST.Expr type, e.g. AST.And.
 
 -- | Generate a binary operator application. The first argument should be a
 -- constructor from the AST.Expr type, e.g. AST.And.


@@ -398,8 +396,8 @@ genFCall' _ (Right name) _ _ = error $ "\nGenerate.genFCall': Cannot generate bu
 genFromSizedWord :: BuiltinBuilder
 genFromSizedWord = genNoInsts $ genExprArgs genFromSizedWord'
 genFromSizedWord' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession [AST.ConcSm]
 genFromSizedWord :: BuiltinBuilder
 genFromSizedWord = genNoInsts $ genExprArgs genFromSizedWord'
 genFromSizedWord' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession [AST.ConcSm]

-genFromSizedWord' (Left res) f args@[arg] = do
-  return $ [mkUncondAssign (Left res) arg]
+genFromSizedWord' (Left res) f args@[arg] =
+  return [mkUncondAssign (Left res) arg]

   -- let fname = varToString f
   -- return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId toIntegerId))  $
   --            map (\exp -> Nothing AST.:=>: AST.ADExpr exp) args
   -- let fname = varToString f
   -- return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId toIntegerId))  $
   --            map (\exp -> Nothing AST.:=>: AST.ADExpr exp) args


@@ -583,7 +581,7 @@ genFold left = genVarArgs (genFold' left)
 
 genFold' :: Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
 genFold' left res f args@[folded_f , start ,vec]= do
 
 genFold' :: Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
 genFold' left res f args@[folded_f , start ,vec]= do

-  len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty (Var.varType vec))
+  len <- MonadState.lift tsType $ tfp_to_int (tfvec_len_ty (Var.varType vec))

   genFold'' len left res f args
 
 genFold'' :: Int -> Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
   genFold'' len left res f args
 
 genFold'' :: Int -> Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])


@@ -653,7 +651,7 @@ genFold'' len left (Left res) f [folded_f, start, vec] = do
                                                                   [Right argexpr2, Right argexpr1]
                                                               )
       -- Return the conditional generate part
                                                                   [Right argexpr2, Right argexpr1]
                                                               )
       -- Return the conditional generate part

-      return $ (AST.GenerateSm cond_label cond_scheme [] app_concsms, used)
+      return (AST.GenerateSm cond_label cond_scheme [] app_concsms, used)

 
     genOtherCell = do
       len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) vec
 
     genOtherCell = do
       len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) vec


@@ -673,7 +671,7 @@ genFold'' len left (Left res) f [folded_f, start, vec] = do
                                                                   [Right argexpr2, Right argexpr1]
                                                               )
       -- Return the conditional generate part
                                                                   [Right argexpr2, Right argexpr1]
                                                               )
       -- Return the conditional generate part

-      return $ (AST.GenerateSm cond_label cond_scheme [] app_concsms, used)
+      return (AST.GenerateSm cond_label cond_scheme [] app_concsms, used)

 
 -- | Generate a generate statement for the builtin function "zip"
 genZip :: BuiltinBuilder
 
 -- | Generate a generate statement for the builtin function "zip"
 genZip :: BuiltinBuilder


@@ -765,7 +763,7 @@ genCopy' :: (Either CoreSyn.CoreBndr AST.VHDLName ) -> CoreSyn.CoreBndr -> [Var.
 genCopy' (Left res) f args@[arg] =
   let
     resExpr = AST.Aggregate [AST.ElemAssoc (Just AST.Others) 
 genCopy' (Left res) f args@[arg] =
   let
     resExpr = AST.Aggregate [AST.ElemAssoc (Just AST.Others) 

-                (AST.PrimName $ (varToVHDLName arg))]
+                (AST.PrimName (varToVHDLName arg))]

     out_assign = mkUncondAssign (Left res) resExpr
   in 
     return [out_assign]
     out_assign = mkUncondAssign (Left res) resExpr
   in 
     return [out_assign]


@@ -890,7 +888,7 @@ genIterateOrGenerate'' len iter (Left res) f [app_f, start] = do
       let argexpr = vhdlNameToVHDLExpr $ mkIndexedName tmp_name n_prev
       (app_concsms, used) <- genApplication (Right resname) app_f [Right argexpr]
       -- Return the conditional generate part
       let argexpr = vhdlNameToVHDLExpr $ mkIndexedName tmp_name n_prev
       (app_concsms, used) <- genApplication (Right resname) app_f [Right argexpr]
       -- Return the conditional generate part

-      return $ (AST.GenerateSm cond_label cond_scheme [] app_concsms, used)
+      return (AST.GenerateSm cond_label cond_scheme [] app_concsms, used)

 
 genBlockRAM :: BuiltinBuilder
 genBlockRAM = genNoInsts $ genExprArgs genBlockRAM'
 
 genBlockRAM :: BuiltinBuilder
 genBlockRAM = genNoInsts $ genExprArgs genBlockRAM'


@@ -964,118 +962,117 @@ genApplication ::
   -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr]) 
   -- ^ The corresponding VHDL concurrent statements and entities
   --   instantiated.
   -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr]) 
   -- ^ The corresponding VHDL concurrent statements and entities
   --   instantiated.

-genApplication dst f args = do
-  case Var.isGlobalId f of
-    False -> do 
-      top <- isTopLevelBinder f
-      case top of
-        True -> do
-          -- Local binder that references a top level binding.  Generate a
-          -- component instantiation.
-          signature <- getEntity f
-          args' <- argsToVHDLExprs args
-          let entity_id = ent_id signature
-          -- TODO: Using show here isn't really pretty, but we'll need some
-          -- unique-ish value...
-          let label = "comp_ins_" ++ (either (prettyShow . varToVHDLName) prettyShow) dst
-          let portmaps = mkAssocElems args' ((either varToVHDLName id) dst) signature
-          return ([mkComponentInst label entity_id portmaps], [f])
-        False -> do
-          -- Not a top level binder, so this must be a local variable reference.
-          -- It should have a representable type (and thus, no arguments) and a
-          -- signal should be generated for it. Just generate an unconditional
-          -- assignment here.
-          f' <- MonadState.lift tsType $ varToVHDLExpr f
-          return $ ([mkUncondAssign dst f'], [])
-    True ->
-      case Var.idDetails f of
-        IdInfo.DataConWorkId dc -> case dst of
-          -- It's a datacon. Create a record from its arguments.
-          Left bndr -> do
-            -- We have the bndr, so we can get at the type
-            htype <- MonadState.lift tsType $ mkHTypeEither (Var.varType bndr)
-            let argsNostate = filter (\x -> not (either hasStateType (\x -> False) x)) args
-            case argsNostate of
-              [arg] -> do
-                [arg'] <- argsToVHDLExprs [arg]
-                return $ ([mkUncondAssign dst arg'], [])
-              otherwise -> do
-                case htype of
-                  Right (AggrType _ _) -> do
-                    labels <- MonadState.lift tsType $ getFieldLabels (Var.varType bndr)
-                    args' <- argsToVHDLExprs argsNostate
-                    return $ (zipWith mkassign labels $ args', [])
-                    where
-                      mkassign :: AST.VHDLId -> AST.Expr -> AST.ConcSm
-                      mkassign label arg =
-                        let sel_name = mkSelectedName ((either varToVHDLName id) dst) label in
-                        mkUncondAssign (Right sel_name) arg
-                  _ -> do -- error $ "DIE!"
-                    args' <- argsToVHDLExprs argsNostate
-                    return $ ([mkUncondAssign dst (head args')], [])            
-          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
-          -- the associated builder if there is any and the argument count matches
-          -- (this should always be the case if it typechecks, but just to be
-          -- sure...).
+genApplication dst f args =
+  if Var.isGlobalId f then
+    case Var.idDetails f of
+      IdInfo.DataConWorkId dc -> case dst of
+        -- It's a datacon. Create a record from its arguments.
+        Left bndr -> do
+          -- We have the bndr, so we can get at the type
+          htype <- MonadState.lift tsType $ mkHTypeEither (Var.varType bndr)
+          let argsNostate = filter (\x -> not (either hasStateType (\x -> False) x)) args
+          case argsNostate of
+            [arg] -> do
+              [arg'] <- argsToVHDLExprs [arg]
+              return ([mkUncondAssign dst arg'], [])
+            otherwise ->
+              case htype of
+                Right (AggrType _ _) -> do
+                  labels <- MonadState.lift tsType $ getFieldLabels (Var.varType bndr)
+                  args' <- argsToVHDLExprs argsNostate
+                  return (zipWith mkassign labels args', [])
+                  where
+                    mkassign :: AST.VHDLId -> AST.Expr -> AST.ConcSm
+                    mkassign label arg =
+                      let sel_name = mkSelectedName ((either varToVHDLName id) dst) label in
+                      mkUncondAssign (Right sel_name) arg
+                _ -> do -- error $ "DIE!"
+                  args' <- argsToVHDLExprs argsNostate
+                  return ([mkUncondAssign dst (head args')], [])            
+        Right _ -> error "\nGenerate.genApplication(DataConWorkId): 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 ->

           case (Map.lookup (varToString f) globalNameTable) of
           case (Map.lookup (varToString f) globalNameTable) of

-            Just (arg_count, builder) ->
-              if length args == arg_count then
-                builder dst f args
+           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(DataConWrapId): Can't generate dataconwrapper: " ++ (show dc)
+        Right _ -> error "\nGenerate.genApplication(DataConWrapId): Can't generate dataconwrapper application without an original binder"
+      IdInfo.VanillaId ->
+        -- It's a global value imported from elsewhere. These can be builtin
+        -- functions. Look up the function name in the name table and execute
+        -- the associated builder if there is any and the argument count matches
+        -- (this should always be the case if it typechecks, but just to be
+        -- sure...).
+        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(VanillaId): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args
+          Nothing -> do
+            top <- isTopLevelBinder f
+            if top then
+              do
+                -- Local binder that references a top level binding.  Generate a
+                -- component instantiation.
+                signature <- getEntity f
+                args' <- argsToVHDLExprs args
+                let entity_id = ent_id signature
+                -- TODO: Using show here isn't really pretty, but we'll need some
+                -- unique-ish value...
+                let label = "comp_ins_" ++ (either show prettyShow) dst
+                let portmaps = mkAssocElems args' ((either varToVHDLName id) dst) signature
+                return ([mkComponentInst label entity_id portmaps], [f])

               else
               else

-                error $ "\nGenerate.genApplication(VanillaId): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args
-            Nothing -> do
-              top <- isTopLevelBinder f
-              case top of
-                True -> do
-                  -- Local binder that references a top level binding.  Generate a
-                  -- component instantiation.
-                  signature <- getEntity f
-                  args' <- argsToVHDLExprs args
-                  let entity_id = ent_id signature
-                  -- TODO: Using show here isn't really pretty, but we'll need some
-                  -- unique-ish value...
-                  let label = "comp_ins_" ++ (either show prettyShow) dst
-                  let portmaps = mkAssocElems args' ((either varToVHDLName id) dst) signature
-                  return ([mkComponentInst label entity_id portmaps], [f])
-                False -> do
-                  -- Not a top level binder, so this must be a local variable reference.
-                  -- It should have a representable type (and thus, no arguments) and a
-                  -- signal should be generated for it. Just generate an unconditional
-                  -- assignment here.
-                  -- FIXME : I DONT KNOW IF THE ABOVE COMMENT HOLDS HERE, SO FOR NOW JUST ERROR!
-                  -- f' <- MonadState.lift tsType $ varToVHDLExpr f
-                  --                   return $ ([mkUncondAssign dst f'], [])
-                  errtype <- case dst of 
+                -- Not a top level binder, so this must be a local variable reference.
+                -- It should have a representable type (and thus, no arguments) and a
+                -- signal should be generated for it. Just generate an unconditional
+                -- assignment here.
+                -- FIXME : I DONT KNOW IF THE ABOVE COMMENT HOLDS HERE, SO FOR NOW JUST ERROR!
+                -- f' <- MonadState.lift tsType $ varToVHDLExpr f
+                --                   return $ ([mkUncondAssign dst f'], [])
+              do errtype <- case dst of 

                     Left bndr -> do 
                       htype <- MonadState.lift tsType $ mkHTypeEither (Var.varType bndr)
                       return (show htype)
                     Right vhd -> return $ show vhd
                     Left bndr -> do 
                       htype <- MonadState.lift tsType $ mkHTypeEither (Var.varType bndr)
                       return (show htype)
                     Right vhd -> return $ show vhd

-                  error $ ("\nGenerate.genApplication(VanillaId): Using function from another module that is not a known builtin: " ++ (pprString f) ++ "::" ++ errtype) 
-        IdInfo.ClassOpId cls -> do
-          -- FIXME: Not looking for what instance this class op is called for
-          -- Is quite stupid of course.
-          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(ClassOpId): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args
-            Nothing -> error $ "\nGenerate.genApplication(ClassOpId): Using function from another module that is not a known builtin: " ++ pprString f
-        details -> error $ "\nGenerate.genApplication: Calling unsupported function " ++ pprString f ++ " with GlobalIdDetails " ++ pprString details
+                 error ("\nGenerate.genApplication(VanillaId): Using function from another module that is not a known builtin: " ++ (pprString f) ++ "::" ++ errtype) 
+      IdInfo.ClassOpId cls ->
+        -- FIXME: Not looking for what instance this class op is called for
+        -- Is quite stupid of course.
+        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(ClassOpId): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args
+          Nothing -> error $ "\nGenerate.genApplication(ClassOpId): Using function from another module that is not a known builtin: " ++ pprString f
+      details -> error $ "\nGenerate.genApplication: Calling unsupported function " ++ pprString f ++ " with GlobalIdDetails " ++ pprString details
+    else do
+      top <- isTopLevelBinder f
+      if top then
+        do
+           -- Local binder that references a top level binding.  Generate a
+           -- component instantiation.
+           signature <- getEntity f
+           args' <- argsToVHDLExprs args
+           let entity_id = ent_id signature
+           -- TODO: Using show here isn't really pretty, but we'll need some
+           -- unique-ish value...
+           let label = "comp_ins_" ++ (either (prettyShow . varToVHDLName) prettyShow) dst
+           let portmaps = mkAssocElems args' ((either varToVHDLName id) dst) signature
+           return ([mkComponentInst label entity_id portmaps], [f])
+        else
+          -- Not a top level binder, so this must be a local variable reference.
+          -- It should have a representable type (and thus, no arguments) and a
+          -- signal should be generated for it. Just generate an unconditional
+          -- assignment here.
+        do f' <- MonadState.lift tsType $ varToVHDLExpr f
+           return ([mkUncondAssign dst f'], [])

 
 -----------------------------------------------------------------------------
 -- Functions to generate functions dealing with vectors.
 
 -----------------------------------------------------------------------------
 -- Functions to generate functions dealing with vectors.


@@ -1151,7 +1148,7 @@ genUnconsVectorFuns elemTM vectorTM  =
     exSpec = AST.Function (mkVHDLExtId exId) [AST.IfaceVarDec vecPar vectorTM,
                                AST.IfaceVarDec ixPar  unsignedTM] elemTM
     exExpr = AST.ReturnSm (Just $ AST.PrimName $ AST.NIndexed 
     exSpec = AST.Function (mkVHDLExtId exId) [AST.IfaceVarDec vecPar vectorTM,
                                AST.IfaceVarDec ixPar  unsignedTM] elemTM
     exExpr = AST.ReturnSm (Just $ AST.PrimName $ AST.NIndexed 

-              (AST.IndexedName (AST.NSimple vecPar) [genExprFCall (mkVHDLBasicId toIntegerId) (AST.PrimName $ AST.NSimple $ ixPar)]))
+              (AST.IndexedName (AST.NSimple vecPar) [genExprFCall (mkVHDLBasicId toIntegerId) (AST.PrimName $ AST.NSimple ixPar)]))

     replaceSpec = AST.Function (mkVHDLExtId replaceId)  [ AST.IfaceVarDec vecPar vectorTM
                                           , AST.IfaceVarDec iPar   unsignedTM
                                           , AST.IfaceVarDec aPar   elemTM
     replaceSpec = AST.Function (mkVHDLExtId replaceId)  [ AST.IfaceVarDec vecPar vectorTM
                                           , AST.IfaceVarDec iPar   unsignedTM
                                           , AST.IfaceVarDec aPar   elemTM


@@ -1168,7 +1165,7 @@ genUnconsVectorFuns elemTM vectorTM  =
                 Nothing
        --  res AST.:= vec(0 to i-1) & a & vec(i+1 to length'vec-1)
     replaceExpr1 = AST.NSimple resId AST.:= AST.PrimName (AST.NSimple vecPar)
                 Nothing
        --  res AST.:= vec(0 to i-1) & a & vec(i+1 to length'vec-1)
     replaceExpr1 = AST.NSimple resId AST.:= AST.PrimName (AST.NSimple vecPar)

-    replaceExpr2 = AST.NIndexed (AST.IndexedName (AST.NSimple resId) [genExprFCall (mkVHDLBasicId toIntegerId) (AST.PrimName $ AST.NSimple $ iPar)]) AST.:= AST.PrimName (AST.NSimple aPar)
+    replaceExpr2 = AST.NIndexed (AST.IndexedName (AST.NSimple resId) [genExprFCall (mkVHDLBasicId toIntegerId) (AST.PrimName $ AST.NSimple iPar)]) AST.:= AST.PrimName (AST.NSimple aPar)

     replaceRet =  AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
     vecSlice init last =  AST.PrimName (AST.NSlice 
                                         (AST.SliceName 
     replaceRet =  AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
     vecSlice init last =  AST.PrimName (AST.NSlice 
                                         (AST.SliceName 


@@ -1176,7 +1173,7 @@ genUnconsVectorFuns elemTM vectorTM  =
                                               (AST.ToRange init last)))
     lastSpec = AST.Function (mkVHDLExtId lastId) [AST.IfaceVarDec vecPar vectorTM] elemTM
        -- return vec(vec'length-1);
                                               (AST.ToRange init last)))
     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 
+    lastExpr = AST.ReturnSm (Just (AST.PrimName $ AST.NIndexed (AST.IndexedName 

                     (AST.NSimple vecPar) 
                     [AST.PrimName (AST.NAttribute $ 
                                 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) 
                     (AST.NSimple vecPar) 
                     [AST.PrimName (AST.NAttribute $ 
                                 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) 


@@ -1310,7 +1307,7 @@ genUnconsVectorFuns elemTM vectorTM  =
     -- for i res'range loop
     --   res(i) := vec(f+i*s);
     -- end loop;
     -- for i res'range loop
     --   res(i) := vec(f+i*s);
     -- end loop;

-    selFor = AST.ForSM iId (AST.AttribRange $ AST.AttribName (AST.NSimple resId) (AST.NSimple $ 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.:*: 
     -- res(i) := vec(f+i*s);
     selAssign = let origExp = AST.PrimName (AST.NSimple fPar) AST.:+: 
                                 (AST.PrimName (AST.NSimple iId) AST.:*: 


@@ -1461,7 +1458,7 @@ genUnconsVectorFuns elemTM vectorTM  =
     --   res(vec'length-i-1) := vec(i);
     -- end loop;
     reverseFor = 
     --   res(vec'length-i-1) := vec(i);
     -- end loop;
     reverseFor = 

-       AST.ForSM iId (AST.AttribRange $ AST.AttribName (AST.NSimple resId) (AST.NSimple $ 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) 
     -- 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) 


@@ -1556,5 +1553,5 @@ globalNameTable = Map.fromList
   , (blockRAMId       , (5, genBlockRAM             ) )
   , (splitId          , (1, genSplit                ) )
   --, (tfvecId          , (1, genTFVec                ) )
   , (blockRAMId       , (5, genBlockRAM             ) )
   , (splitId          , (1, genSplit                ) )
   --, (tfvecId          , (1, genTFVec                ) )

-  , (minimumId        , (2, error $ "\nFunction name: \"minimum\" is used internally, use another name"))
+  , (minimumId        , (2, error "\nFunction name: \"minimum\" is used internally, use another name"))

   ]
   ]

diff --git a/cλash/CLasH/VHDL/Testbench.hs b/cλash/CLasH/VHDL/Testbench.hs
index 89988f5372327b0eb675ecbff08d525ea62a4c73..fa2e9dc7bde21544cc4236db4a0a319309c0f06e 100644 (file)
--- a/cλash/CLasH/VHDL/Testbench.hs
+++ b/cλash/CLasH/VHDL/Testbench.hs
@@ -9,11 +9,11 @@ import qualified Maybe
 import qualified Data.Map as Map
 import qualified Data.Accessor.Monad.Trans.State as MonadState
 
 import qualified Data.Map as Map
 import qualified Data.Accessor.Monad.Trans.State as MonadState
 

--- ForSyDe
+-- VHDL Imports

 import qualified Language.VHDL.AST as AST
 
 -- GHC API
 import qualified Language.VHDL.AST as AST
 
 -- GHC API

-import CoreSyn
+import qualified CoreSyn

 import qualified HscTypes
 import qualified Var
 import qualified TysWiredIn
 import qualified HscTypes
 import qualified Var
 import qualified TysWiredIn


@@ -34,7 +34,7 @@ createTestbench ::
   -> [HscTypes.CoreModule] -- ^ Compiled modules
   -> CoreSyn.CoreExpr -- ^ Input stimuli
   -> CoreSyn.CoreBndr -- ^ Top Entity
   -> [HscTypes.CoreModule] -- ^ Compiled modules
   -> CoreSyn.CoreExpr -- ^ Input stimuli
   -> CoreSyn.CoreBndr -- ^ Top Entity

-  -> TranslatorSession CoreBndr -- ^ The id of the generated archictecture
+  -> TranslatorSession CoreSyn.CoreBndr -- ^ The id of the generated archictecture

 createTestbench mCycles cores stimuli top = do
   stimuli' <- reduceCoreListToHsList cores stimuli
   -- Create a binder for the testbench. We use the unit type (), since the
 createTestbench mCycles cores stimuli top = do
   stimuli' <- reduceCoreListToHsList cores stimuli
   -- Create a binder for the testbench. We use the unit type (), since the


@@ -136,7 +136,7 @@ createStimulans expr cycl = do
   let ([], binds, res) = splitNormalized expr
   (stimulansbindss, useds) <- unzipM $ Monad.mapM mkConcSm binds
   sig_dec_maybes <- mapM (mkSigDec . fst) (filter ((/=res).fst) binds)
   let ([], binds, res) = splitNormalized expr
   (stimulansbindss, useds) <- unzipM $ 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 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 stimulansbindss)
   case (sig_decs,(concat stimulansbindss)) of
   let block_label = mkVHDLExtId ("testcycle_" ++ (show cycl))
   let block = AST.BlockSm block_label [] (AST.PMapAspect []) sig_decs (concat stimulansbindss)
   case (sig_decs,(concat stimulansbindss)) of


@@ -160,7 +160,7 @@ createOutputProc outs =
          [clockId]
          [AST.IfSm clkPred (writeOuts outs) [] Nothing]
  where clkPred = AST.PrimName (AST.NAttribute $ AST.AttribName (AST.NSimple clockId) 
          [clockId]
          [AST.IfSm clkPred (writeOuts outs) [] Nothing]
  where clkPred = AST.PrimName (AST.NAttribute $ AST.AttribName (AST.NSimple clockId) 

-                                                   (AST.NSimple $ eventId)
+                                                   (AST.NSimple eventId)

                                                    Nothing          ) `AST.And` 
                  (AST.PrimName (AST.NSimple clockId) AST.:=: AST.PrimLit "'1'")
        writeOuts :: [AST.VHDLId] -> [AST.SeqSm]
                                                    Nothing          ) `AST.And` 
                  (AST.PrimName (AST.NSimple clockId) AST.:=: AST.PrimLit "'1'")
        writeOuts :: [AST.VHDLId] -> [AST.SeqSm]

diff --git a/cλash/CLasH/VHDL/VHDLTools.hs b/cλash/CLasH/VHDL/VHDLTools.hs
index db3e13acdf200bd199d2f9d49b617722baf3f18d..8b963f53ed3415885649b50bd09633693f4c927d 100644 (file)
--- a/cλash/CLasH/VHDL/VHDLTools.hs
+++ b/cλash/CLasH/VHDL/VHDLTools.hs
@@ -8,22 +8,17 @@ import qualified Data.List as List
 import qualified Data.Char as Char
 import qualified Data.Map as Map
 import qualified Control.Monad as Monad
 import qualified Data.Char as Char
 import qualified Data.Map as Map
 import qualified Control.Monad as Monad

-import qualified Control.Arrow as Arrow
-import qualified Control.Monad.Trans.State as State
-import qualified Data.Monoid as Monoid
-import Data.Accessor.Monad.Trans.State as MonadState
-import Debug.Trace
+import qualified Data.Accessor.Monad.Trans.State as MonadState

 
 

--- ForSyDe
+-- VHDL Imports

 import qualified Language.VHDL.AST as AST
 
 -- GHC API
 import qualified Language.VHDL.AST as AST
 
 -- GHC API

-import CoreSyn
+import qualified CoreSyn

 import qualified Name
 import qualified OccName
 import qualified Var
 import qualified Id
 import qualified Name
 import qualified OccName
 import qualified Var
 import qualified Id

-import qualified IdInfo

 import qualified TyCon
 import qualified Type
 import qualified DataCon
 import qualified TyCon
 import qualified Type
 import qualified DataCon


@@ -44,14 +39,14 @@ import CLasH.VHDL.Constants
 
 -- Create an unconditional assignment statement
 mkUncondAssign ::
 
 -- Create an unconditional assignment statement
 mkUncondAssign ::

-  Either CoreBndr AST.VHDLName -- ^ The signal to assign to
+  Either CoreSyn.CoreBndr AST.VHDLName -- ^ The signal to assign to

   -> AST.Expr -- ^ The expression to assign
   -> AST.ConcSm -- ^ The resulting concurrent statement
 mkUncondAssign dst expr = mkAssign dst Nothing expr
 
 -- Create a conditional assignment statement
 mkCondAssign ::
   -> AST.Expr -- ^ The expression to assign
   -> AST.ConcSm -- ^ The resulting concurrent statement
 mkUncondAssign dst expr = mkAssign dst Nothing expr
 
 -- Create a conditional assignment statement
 mkCondAssign ::

-  Either CoreBndr AST.VHDLName -- ^ The signal to assign to
+  Either CoreSyn.CoreBndr AST.VHDLName -- ^ The signal to assign to

   -> AST.Expr -- ^ The condition
   -> AST.Expr -- ^ The value when true
   -> AST.Expr -- ^ The value when false
   -> AST.Expr -- ^ The condition
   -> AST.Expr -- ^ The value when true
   -> AST.Expr -- ^ The value when false


@@ -60,7 +55,7 @@ mkCondAssign dst cond true false = mkAssign dst (Just (cond, true)) false
 
 -- Create a conditional or unconditional assignment statement
 mkAssign ::
 
 -- Create a conditional or unconditional assignment statement
 mkAssign ::

-  Either CoreBndr AST.VHDLName -- ^ The signal to assign to
+  Either CoreSyn.CoreBndr AST.VHDLName -- ^ The signal to assign to

   -> Maybe (AST.Expr , AST.Expr) -- ^ Optionally, the condition to test for
                                  -- and the value to assign when true.
   -> AST.Expr -- ^ The value to assign when false or no condition
   -> Maybe (AST.Expr , AST.Expr) -- ^ Optionally, the condition to test for
                                  -- and the value to assign when true.
   -> AST.Expr -- ^ The value to assign when false or no condition


@@ -85,12 +80,12 @@ mkAssign dst cond false_expr =
     AST.CSSASm assign
 
 mkAltsAssign ::
     AST.CSSASm assign
 
 mkAltsAssign ::

-  Either CoreBndr AST.VHDLName            -- ^ The signal to assign to
+  Either CoreSyn.CoreBndr AST.VHDLName            -- ^ The signal to assign to

   -> [AST.Expr]       -- ^ The conditions
   -> [AST.Expr]       -- ^ The expressions
   -> AST.ConcSm   -- ^ The Alt assigns
 mkAltsAssign dst conds exprs
   -> [AST.Expr]       -- ^ The conditions
   -> [AST.Expr]       -- ^ The expressions
   -> AST.ConcSm   -- ^ The Alt assigns
 mkAltsAssign dst conds exprs

-        | (length conds) /= ((length exprs) - 1) = error $ "\nVHDLTools.mkAltsAssign: conditions expression mismatch"
+        | (length conds) /= ((length exprs) - 1) = error "\nVHDLTools.mkAltsAssign: conditions expression mismatch"

         | otherwise =
   let
     whenelses   = zipWith mkWhenElse conds exprs
         | otherwise =
   let
     whenelses   = zipWith mkWhenElse conds exprs


@@ -151,7 +146,7 @@ mkComponentInst label entity_id portassigns = AST.CSISm compins
 -----------------------------------------------------------------------------
 
 varToVHDLExpr :: Var.Var -> TypeSession AST.Expr
 -----------------------------------------------------------------------------
 
 varToVHDLExpr :: Var.Var -> TypeSession AST.Expr

-varToVHDLExpr var = do
+varToVHDLExpr var =

   case Id.isDataConWorkId_maybe var of
     Just dc -> dataconToVHDLExpr dc
     -- This is a dataconstructor.
   case Id.isDataConWorkId_maybe var of
     Just dc -> dataconToVHDLExpr dc
     -- This is a dataconstructor.


@@ -168,7 +163,7 @@ varToVHDLExpr var = do
                   case Name.getOccString (TyCon.tyConName tycon) of
                     "Dec" -> do
                       len <- tfp_to_int ty
                   case Name.getOccString (TyCon.tyConName tycon) of
                     "Dec" -> do
                       len <- tfp_to_int ty

-                      return $ AST.PrimLit $ (show len)
+                      return $ AST.PrimLit (show len)

                     otherwise -> return $ AST.PrimName $ AST.NSimple $ varToVHDLId var
 
 -- Turn a VHDLName into an AST expression
                     otherwise -> return $ AST.PrimName $ AST.NSimple $ varToVHDLId var
 
 -- Turn a VHDLName into an AST expression


@@ -184,10 +179,10 @@ exprToVHDLExpr core = varToVHDLExpr (exprToVar core)
 -- dataconstructors, this is only the constructor itself, not any arguments it
 -- has. Should not be called with a DEFAULT constructor.
 altconToVHDLExpr :: CoreSyn.AltCon -> TypeSession AST.Expr
 -- dataconstructors, this is only the constructor itself, not any arguments it
 -- has. Should not be called with a DEFAULT constructor.
 altconToVHDLExpr :: CoreSyn.AltCon -> TypeSession AST.Expr

-altconToVHDLExpr (DataAlt dc) = dataconToVHDLExpr dc
+altconToVHDLExpr (CoreSyn.DataAlt dc) = dataconToVHDLExpr dc

 
 

-altconToVHDLExpr (LitAlt _) = error "\nVHDL.conToVHDLExpr: Literals not support in case alternatives yet"
-altconToVHDLExpr DEFAULT = error "\nVHDL.conToVHDLExpr: DEFAULT alternative should not occur here!"
+altconToVHDLExpr (CoreSyn.LitAlt _) = error "\nVHDL.conToVHDLExpr: Literals not support in case alternatives yet"
+altconToVHDLExpr CoreSyn.DEFAULT = error "\nVHDL.conToVHDLExpr: DEFAULT alternative should not occur here!"

 
 -- Turn a datacon (without arguments!) into a VHDL expression.
 dataconToVHDLExpr :: DataCon.DataCon -> TypeSession AST.Expr
 
 -- Turn a datacon (without arguments!) into a VHDL expression.
 dataconToVHDLExpr :: DataCon.DataCon -> TypeSession AST.Expr


@@ -202,7 +197,7 @@ dataconToVHDLExpr dc = do
         (BuiltinType "Bit") -> return $ AST.PrimLit $ case Name.getOccString dcname of "High" -> "'1'"; "Low" -> "'0'"
         (BuiltinType "Bool") -> return $ AST.PrimLit $ case Name.getOccString dcname of "True" -> "true"; "False" -> "false"
         otherwise -> do
         (BuiltinType "Bit") -> return $ AST.PrimLit $ case Name.getOccString dcname of "High" -> "'1'"; "Low" -> "'0'"
         (BuiltinType "Bool") -> return $ AST.PrimLit $ case Name.getOccString dcname of "True" -> "true"; "False" -> "false"
         otherwise -> do

-          let existing_ty = (Monad.liftM $ fmap fst) $ Map.lookup htype typemap
+          let existing_ty = Monad.liftM (fmap fst) $ Map.lookup htype typemap

           case existing_ty of
             Just ty -> do
               let lit    = idToVHDLExpr $ mkVHDLExtId $ Name.getOccString dcname
           case existing_ty of
             Just ty -> do
               let lit    = idToVHDLExpr $ mkVHDLExtId $ Name.getOccString dcname


@@ -219,7 +214,7 @@ dataconToVHDLExpr dc = do
 varToVHDLId ::
   CoreSyn.CoreBndr
   -> AST.VHDLId
 varToVHDLId ::
   CoreSyn.CoreBndr
   -> AST.VHDLId

-varToVHDLId var = mkVHDLExtId $ (varToString var ++ varToStringUniq var ++ (show $ lowers $ varToStringUniq var))
+varToVHDLId var = mkVHDLExtId (varToString var ++ varToStringUniq var ++ show (lowers $ varToStringUniq var))

   where
     lowers :: String -> Int
     lowers xs = length [x | x <- xs, Char.isLower x]
   where
     lowers :: String -> Int
     lowers xs = length [x | x <- xs, Char.isLower x]


@@ -258,7 +253,7 @@ mkVHDLBasicId s =
     -- Strip leading numbers and underscores
     strip_leading = dropWhile (`elem` ['0'..'9'] ++ "_")
     -- Strip multiple adjacent underscores
     -- Strip leading numbers and underscores
     strip_leading = dropWhile (`elem` ['0'..'9'] ++ "_")
     -- Strip multiple adjacent underscores

-    strip_multiscore = concat . map (\cs -> 
+    strip_multiscore = concatMap (\cs -> 

         case cs of 
           ('_':_) -> "_"
           _ -> cs
         case cs of 
           ('_':_) -> "_"
           _ -> cs


@@ -319,7 +314,7 @@ mkHType msg ty = do
 
 mkHTypeEither :: (TypedThing t, Outputable.Outputable t) => 
   t -> TypeSession (Either String HType)
 
 mkHTypeEither :: (TypedThing t, Outputable.Outputable t) => 
   t -> TypeSession (Either String HType)

-mkHTypeEither tything = do
+mkHTypeEither tything =

   case getType tything of
     Nothing -> return $ Left $ "\nVHDLTools.mkHTypeEither: Typed thing without a type: " ++ pprString tything
     Just ty -> mkHTypeEither' ty
   case getType tything of
     Nothing -> return $ Left $ "\nVHDLTools.mkHTypeEither: Typed thing without a type: " ++ pprString tything
     Just ty -> mkHTypeEither' ty


@@ -327,7 +322,7 @@ mkHTypeEither tything = do
 mkHTypeEither' :: Type.Type -> TypeSession (Either String HType)
 mkHTypeEither' ty | ty_has_free_tyvars ty = return $ Left $ "\nVHDLTools.mkHTypeEither': Cannot create type: type has free type variables: " ++ pprString ty
                   | isStateType ty = return $ Right StateType
 mkHTypeEither' :: Type.Type -> TypeSession (Either String HType)
 mkHTypeEither' ty | ty_has_free_tyvars ty = return $ Left $ "\nVHDLTools.mkHTypeEither': Cannot create type: type has free type variables: " ++ pprString ty
                   | isStateType ty = return $ Right StateType

-                  | otherwise = do
+                  | otherwise =

   case Type.splitTyConApp_maybe ty of
     Just (tycon, args) -> do
       typemap <- MonadState.get tsTypes
   case Type.splitTyConApp_maybe ty of
     Just (tycon, args) -> do
       typemap <- MonadState.get tsTypes


@@ -335,7 +330,7 @@ mkHTypeEither' ty | ty_has_free_tyvars ty = return $ Left $ "\nVHDLTools.mkHType
       let builtinTyMaybe = Map.lookup (BuiltinType name) typemap  
       case builtinTyMaybe of
         (Just x) -> return $ Right $ BuiltinType name
       let builtinTyMaybe = Map.lookup (BuiltinType name) typemap  
       case builtinTyMaybe of
         (Just x) -> return $ Right $ BuiltinType name

-        Nothing -> do
+        Nothing ->

           case name of
                 "TFVec" -> do
                   let el_ty = tfvec_elem ty
           case name of
                 "TFVec" -> do
                   let el_ty = tfvec_elem ty


@@ -357,7 +352,7 @@ mkHTypeEither' ty | ty_has_free_tyvars ty = return $ Left $ "\nVHDLTools.mkHType
                 "RangedWord" -> do
                   bound <- tfp_to_int (ranged_word_bound_ty ty)
                   return $ Right $ RangedWType bound
                 "RangedWord" -> do
                   bound <- tfp_to_int (ranged_word_bound_ty ty)
                   return $ Right $ RangedWType bound

-                otherwise -> do
+                otherwise ->

                   mkTyConHType tycon args
     Nothing -> return $ Left $ "\nVHDLTools.mkHTypeEither': Do not know what to do with type: " ++ pprString ty
 
                   mkTyConHType tycon args
     Nothing -> return $ Left $ "\nVHDLTools.mkHTypeEither': Do not know what to do with type: " ++ pprString ty
 


@@ -372,17 +367,17 @@ mkTyConHType tycon args =
       let real_arg_tys_nostate = filter (\x -> not (isStateType x)) real_arg_tys
       elem_htys_either <- mapM mkHTypeEither real_arg_tys_nostate
       case Either.partitionEithers elem_htys_either of
       let real_arg_tys_nostate = filter (\x -> not (isStateType x)) real_arg_tys
       elem_htys_either <- mapM mkHTypeEither real_arg_tys_nostate
       case Either.partitionEithers elem_htys_either of

-        ([], [elem_hty]) -> do
+        ([], [elem_hty]) ->

           return $ Right elem_hty
         -- No errors in element types
           return $ Right elem_hty
         -- No errors in element types

-        ([], elem_htys) -> do
+        ([], elem_htys) ->

           return $ Right $ AggrType (nameToString (TyCon.tyConName tycon)) elem_htys
         -- There were errors in element types
         (errors, _) -> return $ Left $
           "\nVHDLTools.mkTyConHType: Can not construct type for: " ++ pprString tycon ++ "\n because no type can be construced for some of the arguments.\n"
           ++ (concat errors)
     dcs -> do
           return $ Right $ AggrType (nameToString (TyCon.tyConName tycon)) elem_htys
         -- There were errors in element types
         (errors, _) -> return $ Left $
           "\nVHDLTools.mkTyConHType: Can not construct type for: " ++ pprString tycon ++ "\n because no type can be construced for some of the arguments.\n"
           ++ (concat errors)
     dcs -> do

-      let arg_tys = concat $ map DataCon.dataConRepArgTys dcs
+      let arg_tys = concatMap DataCon.dataConRepArgTys dcs

       let real_arg_tys = map (CoreSubst.substTy subst) arg_tys
       case real_arg_tys of
         [] ->
       let real_arg_tys = map (CoreSubst.substTy subst) arg_tys
       case real_arg_tys of
         [] ->


@@ -400,8 +395,7 @@ vhdlTy :: (TypedThing t, Outputable.Outputable t) =>
   String -> t -> TypeSession (Maybe AST.TypeMark)
 vhdlTy msg ty = do
   htype <- mkHType msg ty
   String -> t -> TypeSession (Maybe AST.TypeMark)
 vhdlTy msg ty = do
   htype <- mkHType msg ty

-  tm <- vhdlTyMaybe htype
-  return tm
+  vhdlTyMaybe htype

 
 vhdlTyMaybe :: HType -> TypeSession (Maybe AST.TypeMark)
 vhdlTyMaybe htype = do
 
 vhdlTyMaybe :: HType -> TypeSession (Maybe AST.TypeMark)
 vhdlTyMaybe htype = do


@@ -426,7 +420,7 @@ vhdlTyMaybe htype = do
 -- message or the resulting typemark and typedef.
 construct_vhdl_ty :: HType -> TypeSession TypeMapRec
 -- State types don't generate VHDL
 -- message or the resulting typemark and typedef.
 construct_vhdl_ty :: HType -> TypeSession TypeMapRec
 -- State types don't generate VHDL

-construct_vhdl_ty htype = do
+construct_vhdl_ty htype =

     case htype of
       StateType -> return  Nothing
       (SizedWType w) -> mkUnsignedTy w
     case htype of
       StateType -> return  Nothing
       (SizedWType w) -> mkUnsignedTy w


@@ -447,7 +441,7 @@ mkTyconTy htype =
           return Nothing
         elem_tys -> do
           let elems = zipWith AST.ElementDec recordlabels elem_tys  
           return Nothing
         elem_tys -> do
           let elems = zipWith AST.ElementDec recordlabels elem_tys  

-          let elem_names = concat $ map prettyShow elem_tys
+          let elem_names = concatMap prettyShow elem_tys

           let ty_id = mkVHDLExtId $ tycon ++ elem_names
           let ty_def = AST.TDR $ AST.RecordTypeDef elems
           let tupshow = mkTupleShow elem_tys ty_id
           let ty_id = mkVHDLExtId $ tycon ++ elem_names
           let ty_def = AST.TDR $ AST.RecordTypeDef elems
           let tupshow = mkTupleShow elem_tys ty_id


@@ -478,7 +472,7 @@ mkVectorTy (VecType len elHType) = do
     (Just elTyTm) -> do
       let ty_id = mkVHDLExtId $ "vector-"++ (AST.fromVHDLId elTyTm) ++ "-0_to_" ++ (show len)
       let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len - 1))]
     (Just elTyTm) -> do
       let ty_id = mkVHDLExtId $ "vector-"++ (AST.fromVHDLId elTyTm) ++ "-0_to_" ++ (show len)
       let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len - 1))]

-      let existing_uvec_ty = (fmap $ fmap fst) $ Map.lookup (UVecType elHType) typesMap
+      let existing_uvec_ty = fmap (fmap fst) $ Map.lookup (UVecType elHType) typesMap

       case existing_uvec_ty of
         Just (Just t) -> do
           let ty_def = AST.SubtypeIn t (Just range)
       case existing_uvec_ty of
         Just (Just t) -> do
           let ty_def = AST.SubtypeIn t (Just range)


@@ -554,9 +548,8 @@ tfp_to_int ty = do
     Just (tycon, args) -> do
       let name = Name.getOccString (TyCon.tyConName tycon)
       case name of
     Just (tycon, args) -> do
       let name = Name.getOccString (TyCon.tyConName tycon)
       case name of

-        "Dec" -> do
-          len <- tfp_to_int' ty
-          return len
+        "Dec" ->
+          tfp_to_int' ty

         otherwise -> do
           MonadState.modify tsTfpInts (Map.insert (OrdType norm_ty) (-1))
           return $ error ("Callin tfp_to_int on non-dec:" ++ (show ty))
         otherwise -> do
           MonadState.modify tsTfpInts (Map.insert (OrdType norm_ty) (-1))
           return $ error ("Callin tfp_to_int on non-dec:" ++ (show ty))


@@ -624,7 +617,7 @@ mkVectorShow elemTM vectorTM =
     resId   = AST.unsafeVHDLBasicId "res"
     headSpec = AST.Function (mkVHDLExtId headId) [AST.IfaceVarDec vecPar vectorTM] elemTM
     -- return vec(0);
     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 
+    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.PrimLit "0"])))
     vecSlice init last =  AST.PrimName (AST.NSlice 
                                       (AST.SliceName 


@@ -710,13 +703,13 @@ mkBuiltInShow = [ AST.SubProgBody showBitSpec [] [showBitExpr]
                         AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerId) 
                         (AST.NIndexed $ AST.IndexedName (AST.NSimple imageId) [signToInt]) Nothing )
                       where
                         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)
+                        signToInt = genExprFCall (mkVHDLBasicId toIntegerId) (AST.PrimName $ AST.NSimple signedPar)

     showUnsignedSpec =  AST.Function showId [AST.IfaceVarDec unsignedPar unsignedTM] stringTM
     showUnsignedExpr =  AST.ReturnSm (Just $
                           AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerId) 
                           (AST.NIndexed $ AST.IndexedName (AST.NSimple imageId) [unsignToInt]) Nothing )
                         where
     showUnsignedSpec =  AST.Function showId [AST.IfaceVarDec unsignedPar unsignedTM] stringTM
     showUnsignedExpr =  AST.ReturnSm (Just $
                           AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerId) 
                           (AST.NIndexed $ AST.IndexedName (AST.NSimple imageId) [unsignToInt]) Nothing )
                         where

-                          unsignToInt = genExprFCall (mkVHDLBasicId toIntegerId) (AST.PrimName $ AST.NSimple $ unsignedPar)
+                          unsignToInt = genExprFCall (mkVHDLBasicId toIntegerId) (AST.PrimName $ AST.NSimple unsignedPar)

     -- showNaturalSpec = AST.Function showId [AST.IfaceVarDec naturalPar naturalTM] stringTM
     -- showNaturalExpr = AST.ReturnSm (Just $
     --                     AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerId)
     -- showNaturalSpec = AST.Function showId [AST.IfaceVarDec naturalPar naturalTM] stringTM
     -- showNaturalExpr = AST.ReturnSm (Just $
     --                     AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerId)

diff --git a/cλash/CLasH/VHDL/VHDLTypes.hs b/cλash/CLasH/VHDL/VHDLTypes.hs
index e95a0c6eac6af1bbd8fe948fc8e769079f82d2e4..38ccc97f875d6de3e32e3d6939d0459eb3e412b3 100644 (file)
--- a/cλash/CLasH/VHDL/VHDLTypes.hs
+++ b/cλash/CLasH/VHDL/VHDLTypes.hs
@@ -1,23 +1,11 @@
 --
 -- Some types used by the VHDL module.
 --
 --
 -- Some types used by the VHDL module.
 --

-{-# LANGUAGE TemplateHaskell #-}

 module CLasH.VHDL.VHDLTypes where
 
 module CLasH.VHDL.VHDLTypes where
 

--- Standard imports
-import qualified Control.Monad.Trans.State as State
-import qualified Data.Map as Map
-import Data.Accessor
-import qualified Data.Accessor.Template
-
--- GHC API imports
-import qualified HscTypes
-
--- ForSyDe imports
+-- VHDL imports

 import qualified Language.VHDL.AST as AST
 
 import qualified Language.VHDL.AST as AST
 

--- Local imports
-

 -- A description of a port of an entity
 type Port = (AST.VHDLId, AST.TypeMark)
 
 -- A description of a port of an entity
 type Port = (AST.VHDLId, AST.TypeMark)