data Bit = High | Low
deriving (P.Show, P.Eq, P.Read, Typeable)
-$(deriveLift1 ''Bit)
+deriveLift1 ''Bit
hwand :: Bit -> Bit -> Bit
hwor :: Bit -> Bit -> Bit
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
--------------------------------
-- 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
-- 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')
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)
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
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
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
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,
-- 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
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?
-- 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
-{-# 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
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
module CLasH.Translator
- ( -- makeVHDLStrings
+ (
makeVHDLAnnotations
) where
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
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)
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.
-> 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)
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.
-- 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:
{-# 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
+{-# 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
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
}
-- Derive accessors
-$( Data.Accessor.Template.deriveAccessors ''TypeState )
+Data.Accessor.Template.deriveAccessors ''TypeState
-- Define a session
type TypeSession = State.State TypeState
}
-- Derive accessors
-$( Data.Accessor.Template.deriveAccessors ''TranslatorState )
+Data.Accessor.Template.deriveAccessors ''TranslatorState
type TranslatorSession = State.State TranslatorState
-- 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) =>
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
import qualified SrcLoc
import qualified IdInfo
import qualified CoreUtils
-import qualified CoreSubst
-import qualified VarSet
-import qualified HscTypes
-- Local imports
import CLasH.Translator.TranslatorTypes
-- 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
-- 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
{-# 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)
-- 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" ""
| 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)
instance (Outputable x) => Show x where
- show x = "__" ++ (showSDoc $ ppr x) ++ "__"
+ show x = "__" ++ showSDoc (ppr x) ++ "__"
--Standard modules
import qualified Maybe
-import System.IO.Unsafe
+import qualified System.IO.Unsafe
-- GHC API
import qualified GHC
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
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
-- 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
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'
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
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
-- 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
, [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
binders <- findBinder criteria core
case binders of
[] -> return Nothing
- bndrs -> return $ Just $ (map snd bndrs)
+ bndrs -> return $ Just (map snd bndrs)
findExpr ::
Monad m =>
-> 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 ::
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 ::
-{-# LANGUAGE ViewPatterns #-}
module CLasH.Utils.HsTools where
-- Standard modules
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
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
-- 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
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
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
-- 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
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
module CLasH.VHDL.Constants where
-
+
+-- VHDL Imports
import qualified Language.VHDL.AST as AST
--------------
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 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
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
-> 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
-- 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
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
-- 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
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)
Just _ -> do
vhdl_expr <- varToVHDLExpr $ exprToVar expr
return $ Just vhdl_expr
- Nothing -> return $ Nothing
+ Nothing -> return Nothing
argToVHDLExpr (Right expr) = return $ Just expr
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.
-> ((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.
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
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])
[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
[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
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]
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'
-> 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.
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
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
(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)
-- 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(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)
, (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"))
]
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
-> [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
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
[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]
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
-- 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
-- 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
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
-----------------------------------------------------------------------------
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 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
-- 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
(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
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]
-- 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
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
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
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
"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
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
[] ->
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
-- 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
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
(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)
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))
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.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)
--
-- 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)
projects / matthijs / master-project / cλash.git / commitdiff