From f3951a1376fc7d7f8addbe9e9fed071320502100 Mon Sep 17 00:00:00 2001 From: Christiaan Baaij Date: Wed, 11 Nov 2009 15:49:50 +0100 Subject: [PATCH] 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' --- "c\316\273ash/CLasH/HardwareTypes.hs" | 2 +- "c\316\273ash/CLasH/Normalize.hs" | 21 +- .../CLasH/Normalize/NormalizeTools.hs" | 34 +-- .../CLasH/Normalize/NormalizeTypes.hs" | 15 +- "c\316\273ash/CLasH/Translator.hs" | 26 +- .../CLasH/Translator/Annotations.hs" | 4 +- .../CLasH/Translator/TranslatorTypes.hs" | 9 +- "c\316\273ash/CLasH/Utils.hs" | 6 +- .../CLasH/Utils/Core/BinderTools.hs" | 19 +- "c\316\273ash/CLasH/Utils/Core/CoreShow.hs" | 16 +- "c\316\273ash/CLasH/Utils/Core/CoreTools.hs" | 18 +- "c\316\273ash/CLasH/Utils/GhcTools.hs" | 17 +- "c\316\273ash/CLasH/Utils/HsTools.hs" | 18 +- "c\316\273ash/CLasH/Utils/Pretty.hs" | 12 +- "c\316\273ash/CLasH/VHDL.hs" | 28 +- "c\316\273ash/CLasH/VHDL/Constants.hs" | 3 +- "c\316\273ash/CLasH/VHDL/Generate.hs" | 267 +++++++++--------- "c\316\273ash/CLasH/VHDL/Testbench.hs" | 10 +- "c\316\273ash/CLasH/VHDL/VHDLTools.hs" | 71 +++-- "c\316\273ash/CLasH/VHDL/VHDLTypes.hs" | 14 +- 20 files changed, 252 insertions(+), 358 deletions(-) diff --git "a/c\316\273ash/CLasH/HardwareTypes.hs" "b/c\316\273ash/CLasH/HardwareTypes.hs" index e6e84fd..3b746aa 100644 --- "a/c\316\273ash/CLasH/HardwareTypes.hs" +++ "b/c\316\273ash/CLasH/HardwareTypes.hs" @@ -51,7 +51,7 @@ resizeWord = SizedWord.resize data Bit = High | Low deriving (P.Show, P.Eq, P.Read, Typeable) -$(deriveLift1 ''Bit) +deriveLift1 ''Bit hwand :: Bit -> Bit -> Bit hwor :: Bit -> Bit -> Bit diff --git "a/c\316\273ash/CLasH/Normalize.hs" "b/c\316\273ash/CLasH/Normalize.hs" index 40eab93..17143ff 100644 --- "a/c\316\273ash/CLasH/Normalize.hs" +++ "b/c\316\273ash/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 Data.Map as Map import qualified Data.Monoid as Monoid -import Data.Accessor -- GHC API import CoreSyn -import qualified UniqSupply import qualified CoreUtils import qualified Type -import qualified TcType -import qualified Name import qualified Id import qualified Var import qualified VarSet -import qualified NameSet import qualified CoreFVs -import qualified CoreUtils 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 CLasH.VHDL.VHDLTypes 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 -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 @@ -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. - 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') @@ -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. - return $ (Just (id, expr), Var id) + return (Just (id, expr), Var id) 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 - 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 @@ -699,7 +690,7 @@ getNormalized :: 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 @@ -729,7 +720,7 @@ getBinding :: 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 diff --git "a/c\316\273ash/CLasH/Normalize/NormalizeTools.hs" "b/c\316\273ash/CLasH/Normalize/NormalizeTools.hs" index 936a4ec..1995e38 100644 --- "a/c\316\273ash/CLasH/Normalize/NormalizeTools.hs" +++ "b/c\316\273ash/CLasH/Normalize/NormalizeTools.hs" @@ -5,35 +5,27 @@ module CLasH.Normalize.NormalizeTools where -- Standard modules -import Debug.Trace -import qualified List 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.Trans.State as State 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 -import qualified CoreUtils 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 -import CLasH.Utils.Pretty 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, @@ -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 -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' - 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 --- 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 --- trace ("No changes") $ + -- trace ("No changes") $ 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 - return $ not $ v `elem` bndrs + return $ v `notElem` bndrs 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 -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 diff --git "a/c\316\273ash/CLasH/Normalize/NormalizeTypes.hs" "b/c\316\273ash/CLasH/Normalize/NormalizeTypes.hs" index a13ca0f..3affc87 100644 --- "a/c\316\273ash/CLasH/Normalize/NormalizeTypes.hs" +++ "b/c\316\273ash/CLasH/Normalize/NormalizeTypes.hs" @@ -1,24 +1,13 @@ -{-# LANGUAGE TemplateHaskell #-} module CLasH.Normalize.NormalizeTypes where - -- 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.Accessor.Template -import Data.Accessor -import qualified Data.Map as Map -import Debug.Trace -- GHC API -import CoreSyn -import qualified VarSet -import Outputable ( Outputable, showSDoc, ppr ) +import qualified CoreSyn -- 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 @@ -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 Transform = CoreExpr -> TransformMonad CoreExpr +type Transform = CoreSyn.CoreExpr -> TransformMonad CoreSyn.CoreExpr diff --git "a/c\316\273ash/CLasH/Translator.hs" "b/c\316\273ash/CLasH/Translator.hs" index 16158d2..04b7beb 100644 --- "a/c\316\273ash/CLasH/Translator.hs" +++ "b/c\316\273ash/CLasH/Translator.hs" @@ -1,5 +1,5 @@ module CLasH.Translator - ( -- makeVHDLStrings + ( 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 Debug.Trace -- 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 Language.VHDL.FileIO +import qualified Language.VHDL.FileIO as FileIO 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.Utils.Core.CoreTools 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 () -makeVHDLAnnotations libdir filenames = do +makeVHDLAnnotations libdir filenames = 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 - mapM (writeVHDL dir) vhdl + mapM_ (writeVHDL dir) 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 - 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 - 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 - mapM_ printAnns specs 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) - mapM (putStr . render . Ppr.ppr . snd) vhdl + mapM_ (putStr . render . Ppr.ppr . snd) vhdl 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 - 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. @@ -154,6 +146,6 @@ writeVHDL dir (name, vhdl) = do -- 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: diff --git "a/c\316\273ash/CLasH/Translator/Annotations.hs" "b/c\316\273ash/CLasH/Translator/Annotations.hs" index 6176438..2c87550 100644 --- "a/c\316\273ash/CLasH/Translator/Annotations.hs" +++ "b/c\316\273ash/CLasH/Translator/Annotations.hs" @@ -1,10 +1,10 @@ {-# LANGUAGE DeriveDataTypeable #-} module CLasH.Translator.Annotations where -import Language.Haskell.TH +import qualified Language.Haskell.TH as TH 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 diff --git "a/c\316\273ash/CLasH/Translator/TranslatorTypes.hs" "b/c\316\273ash/CLasH/Translator/TranslatorTypes.hs" index 56c5c75..d840256 100644 --- "a/c\316\273ash/CLasH/Translator/TranslatorTypes.hs" +++ "b/c\316\273ash/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. -- -{-# LANGUAGE TemplateHaskell #-} module CLasH.Translator.TranslatorTypes where -- Standard modules @@ -18,12 +18,11 @@ import qualified Type import qualified HscTypes import qualified UniqSupply --- ForSyDe +-- VHDL Imports 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 @@ -80,7 +79,7 @@ data TypeState = TypeState { } -- Derive accessors -$( Data.Accessor.Template.deriveAccessors ''TypeState ) +Data.Accessor.Template.deriveAccessors ''TypeState -- Define a session type TypeSession = State.State TypeState @@ -97,7 +96,7 @@ data TranslatorState = TranslatorState { } -- Derive accessors -$( Data.Accessor.Template.deriveAccessors ''TranslatorState ) +Data.Accessor.Template.deriveAccessors ''TranslatorState type TranslatorSession = State.State TranslatorState diff --git "a/c\316\273ash/CLasH/Utils.hs" "b/c\316\273ash/CLasH/Utils.hs" index 51c6ebf..41d7bee 100644 --- "a/c\316\273ash/CLasH/Utils.hs" +++ "b/c\316\273ash/CLasH/Utils.hs" @@ -3,14 +3,10 @@ module CLasH.Utils where -- 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 - --- GHC API - --- Local Imports -- Make a caching version of a stateful computatation. makeCached :: (Monad m, Ord k) => diff --git "a/c\316\273ash/CLasH/Utils/Core/BinderTools.hs" "b/c\316\273ash/CLasH/Utils/Core/BinderTools.hs" index ef69474..8d0751b 100644 --- "a/c\316\273ash/CLasH/Utils/Core/BinderTools.hs" +++ "b/c\316\273ash/CLasH/Utils/Core/BinderTools.hs" @@ -4,10 +4,10 @@ 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 -import CoreSyn +import qualified CoreSyn 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 CoreSubst -import qualified VarSet -import qualified HscTypes -- 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). -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 -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 @@ -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. -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 diff --git "a/c\316\273ash/CLasH/Utils/Core/CoreShow.hs" "b/c\316\273ash/CLasH/Utils/Core/CoreShow.hs" index 1db286e..ca2a7fb 100644 --- "a/c\316\273ash/CLasH/Utils/Core/CoreShow.hs" +++ "b/c\316\273ash/CLasH/Utils/Core/CoreShow.hs" @@ -1,23 +1,21 @@ {-# LANGUAGE StandaloneDeriving,FlexibleInstances, UndecidableInstances, OverlappingInstances #-} -module CLasH.Utils.Core.CoreShow where - +-- -- This module derives Show instances for CoreSyn types. +-- +module CLasH.Utils.Core.CoreShow where +-- GHC API import qualified BasicTypes - 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 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) @@ -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 - 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" "" @@ -55,7 +53,7 @@ instance Show TyCon.TyCon where | 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) @@ -79,4 +77,4 @@ instance Show (HsExpr.GRHSs id) where instance (Outputable x) => Show x where - show x = "__" ++ (showSDoc $ ppr x) ++ "__" + show x = "__" ++ showSDoc (ppr x) ++ "__" diff --git "a/c\316\273ash/CLasH/Utils/Core/CoreTools.hs" "b/c\316\273ash/CLasH/Utils/Core/CoreTools.hs" index acc2fa6..19c1270 100644 --- "a/c\316\273ash/CLasH/Utils/Core/CoreTools.hs" +++ "b/c\316\273ash/CLasH/Utils/Core/CoreTools.hs" @@ -7,7 +7,7 @@ module CLasH.Utils.Core.CoreTools where --Standard modules import qualified Maybe -import System.IO.Unsafe +import qualified System.IO.Unsafe -- GHC API import qualified GHC @@ -15,30 +15,23 @@ import qualified Type import qualified TcType import qualified HsExpr import qualified HsTypes -import qualified HsBinds import qualified HscTypes -import qualified RdrName import qualified Name -import qualified OccName -import qualified Type 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 Unique import qualified CoreUtils import qualified CoreFVs import qualified Literal import qualified MkCore import qualified VarEnv -import qualified Literal -- 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 = - 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 @@ -278,7 +270,7 @@ reduceCoreListToHsList _ _ = return [] -- 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 @@ -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) - 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' diff --git "a/c\316\273ash/CLasH/Utils/GhcTools.hs" "b/c\316\273ash/CLasH/Utils/GhcTools.hs" index c11b548..fc63ac4 100644 --- "a/c\316\273ash/CLasH/Utils/GhcTools.hs" +++ "b/c\316\273ash/CLasH/Utils/GhcTools.hs" @@ -29,8 +29,8 @@ import CLasH.Utils 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 @@ -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 - mapM listBinding bindings + mapM_ listBinding bindings 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 = - System.IO.Unsafe.unsafePerformIO $ do + System.IO.Unsafe.unsafePerformIO $ 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 = - GHC.defaultErrorHandler DynFlags.defaultDynFlags $ do + GHC.defaultErrorHandler DynFlags.defaultDynFlags $ 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 - bndrs -> return $ Just $ (map snd bndrs) + bndrs -> return $ Just (map snd bndrs) 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 - 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 :: @@ -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 -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 :: diff --git "a/c\316\273ash/CLasH/Utils/HsTools.hs" "b/c\316\273ash/CLasH/Utils/HsTools.hs" index ca20441..c08bad7 100644 --- "a/c\316\273ash/CLasH/Utils/HsTools.hs" +++ "b/c\316\273ash/CLasH/Utils/HsTools.hs" @@ -1,4 +1,3 @@ -{-# LANGUAGE ViewPatterns #-} 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 InstEnv -import qualified FamInstEnv 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 Bag -- 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 @@ -96,15 +86,14 @@ toCore expr = do 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 - 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 @@ -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 - return id 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 - 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 diff --git "a/c\316\273ash/CLasH/Utils/Pretty.hs" "b/c\316\273ash/CLasH/Utils/Pretty.hs" index 56b3aaf..df78ad9 100644 --- "a/c\316\273ash/CLasH/Utils/Pretty.hs" +++ "b/c\316\273ash/CLasH/Utils/Pretty.hs" @@ -1,21 +1,19 @@ module CLasH.Utils.Pretty (prettyShow, pprString, pprStringDebug) where - +-- Standard imports 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 Module -import qualified HscTypes -import Text.PrettyPrint.HughesPJClass 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 CLasH.Translator.TranslatorTypes +-- Local imports import CLasH.VHDL.VHDLTypes import CLasH.Utils.Core.CoreShow diff --git "a/c\316\273ash/CLasH/VHDL.hs" "b/c\316\273ash/CLasH/VHDL.hs" index 21671ad..56342fc 100644 --- "a/c\316\273ash/CLasH/VHDL.hs" +++ "b/c\316\273ash/CLasH/VHDL.hs" @@ -6,38 +6,22 @@ module CLasH.VHDL where -- 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.Monad.Trans.State as State -import qualified Data.Monoid as Monoid 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 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 -import CLasH.Utils.Pretty -import CLasH.Utils.Core.CoreTools import CLasH.VHDL.Constants import CLasH.VHDL.Generate -import CLasH.VHDL.Testbench createDesignFiles :: [CoreSyn.CoreBndr] -- ^ Top binders @@ -83,16 +67,16 @@ createTypesPackage :: 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 - 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 - 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 diff --git "a/c\316\273ash/CLasH/VHDL/Constants.hs" "b/c\316\273ash/CLasH/VHDL/Constants.hs" index 8c96148..22bf14a 100644 --- "a/c\316\273ash/CLasH/VHDL/Constants.hs" +++ "b/c\316\273ash/CLasH/VHDL/Constants.hs" @@ -1,5 +1,6 @@ module CLasH.VHDL.Constants where - + +-- VHDL Imports import qualified Language.VHDL.AST as AST -------------- diff --git "a/c\316\273ash/CLasH/VHDL/Generate.hs" "b/c\316\273ash/CLasH/VHDL/Generate.hs" index 4b24b57..0141db4 100644 --- "a/c\316\273ash/CLasH/VHDL/Generate.hs" +++ "b/c\316\273ash/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 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 @@ -27,7 +26,7 @@ import CLasH.Translator.TranslatorTypes 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 @@ -41,7 +40,7 @@ getEntity :: 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 @@ -109,7 +108,7 @@ getArchitecture :: -> 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 @@ -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) - 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 @@ -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 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 @@ -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). -mkConcSm (bndr, CoreSyn.Var v) = do +mkConcSm (bndr, CoreSyn.Var v) = 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], []) - otherwise -> do + otherwise -> 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 - Nothing -> return $ Nothing + Nothing -> return Nothing 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 - let litargs = concat (map (getLiterals hscenv) exprargs) + let litargs = concatMap (getLiterals hscenv) exprargs 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. @@ -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 - 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. @@ -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' (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 @@ -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 - 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]) @@ -653,7 +651,7 @@ genFold'' len left (Left res) f [folded_f, start, vec] = do [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 @@ -673,7 +671,7 @@ genFold'' len left (Left res) f [folded_f, start, vec] = do [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 @@ -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) - (AST.PrimName $ (varToVHDLName arg))] + (AST.PrimName (varToVHDLName arg))] 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 - 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' @@ -964,118 +962,117 @@ genApplication :: -> 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 - 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 - 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 - 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. @@ -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 - (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 @@ -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) - 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 @@ -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); - 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) @@ -1310,7 +1307,7 @@ genUnconsVectorFuns elemTM vectorTM = -- for i res'range loop -- res(i) := vec(f+i*s); -- end loop; - selFor = AST.ForSM iId (AST.AttribRange $ AST.AttribName (AST.NSimple resId) (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.:*: @@ -1461,7 +1458,7 @@ genUnconsVectorFuns elemTM vectorTM = -- 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) @@ -1556,5 +1553,5 @@ globalNameTable = Map.fromList , (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\316\273ash/CLasH/VHDL/Testbench.hs" "b/c\316\273ash/CLasH/VHDL/Testbench.hs" index 89988f5..fa2e9dc 100644 --- "a/c\316\273ash/CLasH/VHDL/Testbench.hs" +++ "b/c\316\273ash/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 --- ForSyDe +-- VHDL Imports import qualified Language.VHDL.AST as AST -- GHC API -import CoreSyn +import qualified CoreSyn 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 - -> 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 @@ -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 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 @@ -160,7 +160,7 @@ createOutputProc outs = [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] diff --git "a/c\316\273ash/CLasH/VHDL/VHDLTools.hs" "b/c\316\273ash/CLasH/VHDL/VHDLTools.hs" index db3e13a..8b963f5 100644 --- "a/c\316\273ash/CLasH/VHDL/VHDLTools.hs" +++ "b/c\316\273ash/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 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 CoreSyn +import qualified CoreSyn import qualified Name import qualified OccName import qualified Var import qualified Id -import qualified IdInfo import qualified TyCon import qualified Type import qualified DataCon @@ -44,14 +39,14 @@ import CLasH.VHDL.Constants -- 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 :: - 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 @@ -60,7 +55,7 @@ mkCondAssign dst cond true false = mkAssign dst (Just (cond, true)) false -- 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 @@ -85,12 +80,12 @@ mkAssign dst cond false_expr = 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 - | (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 @@ -151,7 +146,7 @@ mkComponentInst label entity_id portassigns = AST.CSISm compins ----------------------------------------------------------------------------- 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. @@ -168,7 +163,7 @@ varToVHDLExpr var = do 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 @@ -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 -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 @@ -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 - 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 @@ -219,7 +214,7 @@ dataconToVHDLExpr dc = do 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] @@ -258,7 +253,7 @@ mkVHDLBasicId s = -- 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 @@ -319,7 +314,7 @@ mkHType msg ty = do 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 @@ -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 - | otherwise = do + | otherwise = 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 - Nothing -> do + Nothing -> 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 - otherwise -> do + otherwise -> 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 - ([], [elem_hty]) -> do + ([], [elem_hty]) -> 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 - 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 [] -> @@ -400,8 +395,7 @@ vhdlTy :: (TypedThing t, Outputable.Outputable t) => 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 @@ -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 -construct_vhdl_ty htype = do +construct_vhdl_ty htype = 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 - 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 @@ -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))] - 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) @@ -554,9 +548,8 @@ tfp_to_int ty = do 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)) @@ -624,7 +617,7 @@ mkVectorShow elemTM vectorTM = 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 @@ -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 - 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 - 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) diff --git "a/c\316\273ash/CLasH/VHDL/VHDLTypes.hs" "b/c\316\273ash/CLasH/VHDL/VHDLTypes.hs" index e95a0c6..38ccc97 100644 --- "a/c\316\273ash/CLasH/VHDL/VHDLTypes.hs" +++ "b/c\316\273ash/CLasH/VHDL/VHDLTypes.hs" @@ -1,23 +1,11 @@ -- -- Some types used by the VHDL module. -- -{-# LANGUAGE TemplateHaskell #-} 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 --- Local imports - -- A description of a port of an entity type Port = (AST.VHDLId, AST.TypeMark) -- 2.30.2