-- top level function "normalize", and defines the actual transformation passes that
-- are performed.
--
-module CLasH.Normalize (normalizeModule) where
+module CLasH.Normalize (getNormalized, normalizeExpr) where
-- Standard modules
import Debug.Trace
-- Local imports
import CLasH.Normalize.NormalizeTypes
+import CLasH.Translator.TranslatorTypes
import CLasH.Normalize.NormalizeTools
import CLasH.VHDL.VHDLTypes
+import qualified CLasH.Utils as Utils
import CLasH.Utils.Core.CoreTools
+import CLasH.Utils.Core.BinderTools
import CLasH.Utils.Pretty
--------------------------------
eta, etatop :: Transform
eta expr | is_fun expr && not (is_lam expr) = do
let arg_ty = (fst . Type.splitFunTy . CoreUtils.exprType) expr
- id <- mkInternalVar "param" arg_ty
+ id <- Trans.lift $ mkInternalVar "param" arg_ty
change (Lam id (App expr (Var id)))
-- Leave all other expressions unchanged
eta e = return e
then do
-- If the result is not a local var already (to prevent loops with
-- ourselves), extract it.
- id <- mkInternalVar "foo" (CoreUtils.exprType res)
+ id <- Trans.lift $ mkInternalVar "foo" (CoreUtils.exprType res)
let bind = (id, res)
change $ Let (Rec (bind:binds)) (Var id)
else
repr <- isRepr scrut
if repr
then do
- id <- mkInternalVar "scrut" (CoreUtils.exprType scrut)
+ id <- Trans.lift $ mkInternalVar "scrut" (CoreUtils.exprType scrut)
change $ Let (Rec [(id, scrut)]) (Case (Var id) b ty alts)
else
return expr
-- Create on new binder that will actually capture a value in this
-- case statement, and return it.
let bty = (Id.idType b)
- id <- mkInternalVar "sel" bty
+ id <- Trans.lift $ mkInternalVar "sel" bty
let binders = take i wildbndrs ++ [id] ++ drop (i+1) wildbndrs
let caseexpr = Case scrut b bty [(con, binders, Var id)]
return (wildbndrs!!i, Just (b, caseexpr))
-- prevent loops with inlinenonrep).
if (not uses_bndrs) && (not local_var) && repr
then do
- id <- mkInternalVar "caseval" (CoreUtils.exprType expr)
+ id <- Trans.lift $ mkInternalVar "caseval" (CoreUtils.exprType expr)
-- 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)
local_var <- Trans.lift $ is_local_var arg
if repr && not local_var
then do -- Extract representable arguments
- id <- mkInternalVar "arg" (CoreUtils.exprType arg)
+ id <- Trans.lift $ mkInternalVar "arg" (CoreUtils.exprType arg)
change $ Let (Rec [(id, arg)]) (App f (Var id))
else -- Leave non-representable arguments unchanged
return expr
-- the old body applied to some arguments.
let newbody = MkCore.mkCoreLams newparams (MkCore.mkCoreApps body oldargs)
-- Create a new function with the same name but a new body
- newf <- mkFunction f newbody
+ newf <- Trans.lift $ mkFunction f newbody
-- Replace the original application with one of the new function to the
-- new arguments.
change $ MkCore.mkCoreApps (Var newf) newargs
-- Representable types will not be propagated, and arguments with free
-- type variables will be propagated later.
-- TODO: preserve original naming?
- id <- mkBinderFor arg "param"
+ id <- Trans.lift $ mkBinderFor arg "param"
-- Just pass the original argument to the new function, which binds it
-- to a new id and just pass that new id to the old function body.
return ([arg], [id], mkReferenceTo id)
-- by the argument expression.
let free_vars = VarSet.varSetElems $ CoreFVs.exprFreeVars arg
let body = MkCore.mkCoreLams free_vars arg
- id <- mkBinderFor body "fun"
+ id <- Trans.lift $ mkBinderFor body "fun"
Trans.lift $ addGlobalBind id body
-- Replace the argument with a reference to the new function, applied to
-- all vars it uses.
-- What transforms to run?
transforms = [argproptop, funextracttop, etatop, betatop, castproptop, letremovetop, letrectop, letsimpltop, letflattop, scrutsimpltop, casesimpltop, caseremovetop, inlinenonreptop, appsimpltop]
--- Turns the given bind into VHDL
-normalizeModule ::
- HscTypes.HscEnv
- -> UniqSupply.UniqSupply -- ^ A UniqSupply we can use
- -> [(CoreBndr, CoreExpr)] -- ^ All bindings we know (i.e., in the current module)
- -> [CoreExpr]
- -> [CoreBndr] -- ^ The bindings to generate VHDL for (i.e., the top level bindings)
- -> [Bool] -- ^ For each of the bindings to generate VHDL for, if it is stateful
- -> ([(CoreBndr, CoreExpr)], [(CoreBndr, CoreExpr)], TypeState) -- ^ The resulting VHDL
-
-normalizeModule env uniqsupply bindings testexprs generate_for statefuls = runTransformSession env uniqsupply $ do
- testbinds <- mapM (\x -> do { v <- mkBinderFor' x "test" ; return (v,x) } ) testexprs
- let testbinders = (map fst testbinds)
- -- Put all the bindings in this module in the tsBindings map
- putA tsBindings (Map.fromList (bindings ++ testbinds))
- -- (Recursively) normalize each of the requested bindings
- mapM normalizeBind (generate_for ++ testbinders)
- -- Get all initial bindings and the ones we produced
- bindings_map <- getA tsBindings
- let bindings = Map.assocs bindings_map
- normalized_binders' <- getA tsNormalized
- let normalized_binders = VarSet.delVarSetList normalized_binders' testbinders
- let ret_testbinds = zip testbinders (Maybe.catMaybes $ map (\x -> lookup x bindings) testbinders)
- let ret_binds = filter ((`VarSet.elemVarSet` normalized_binders) . fst) bindings
- typestate <- getA tsType
- -- But return only the normalized bindings
- return $ (ret_binds, ret_testbinds, typestate)
-
-normalizeBind :: CoreBndr -> TransformSession ()
-normalizeBind bndr =
- -- Don't normalize global variables, these should be either builtin
- -- functions or data constructors.
- Monad.when (Var.isLocalId bndr) $ do
- -- Skip binders that have a polymorphic type, since it's impossible to
- -- create polymorphic hardware.
- if is_poly (Var bndr)
- then
- -- This should really only happen at the top level... TODO: Give
- -- a different error if this happens down in the recursion.
- error $ "\nNormalize.normalizeBind: Function " ++ show bndr ++ " is polymorphic, can't normalize"
- else do
- normalized_funcs <- getA tsNormalized
- -- See if this function was normalized already
- if VarSet.elemVarSet bndr normalized_funcs
- then
- -- Yup, don't do it again
- return ()
- else do
- -- Nope, note that it has been and do it.
- modA tsNormalized (flip VarSet.extendVarSet bndr)
- expr_maybe <- getGlobalBind bndr
- case expr_maybe of
- Just expr -> do
- -- Introduce an empty Let at the top level, so there will always be
- -- a let in the expression (none of the transformations will remove
- -- the last let).
- let expr' = Let (Rec []) expr
- -- Normalize this expression
- trace ("Transforming " ++ (show bndr) ++ "\nBefore:\n\n" ++ showSDoc ( ppr expr' ) ++ "\n") $ return ()
- expr' <- dotransforms transforms expr'
- trace ("\nAfter:\n\n" ++ showSDoc ( ppr expr')) $ return ()
- -- And store the normalized version in the session
- modA tsBindings (Map.insert bndr expr')
- -- Find all vars used with a function type. All of these should be global
- -- binders (i.e., functions used), since any local binders with a function
- -- type should have been inlined already.
- bndrs <- getGlobalBinders
- let used_funcs_set = CoreFVs.exprSomeFreeVars (\v -> not (Id.isDictId v) && v `elem` bndrs) expr'
- let used_funcs = VarSet.varSetElems used_funcs_set
- -- Process each of the used functions recursively
- mapM normalizeBind used_funcs
- return ()
- -- We don't have a value for this binder. This really shouldn't
- -- happen for local id's...
- Nothing -> error $ "\nNormalize.normalizeBind: No value found for binder " ++ pprString bndr ++ "? This should not happen!"
+-- | Returns the normalized version of the given function.
+getNormalized ::
+ CoreBndr -- ^ The function to get
+ -> TranslatorSession CoreExpr -- The normalized function body
+
+getNormalized bndr = Utils.makeCached bndr tsNormalized $ do
+ if is_poly (Var bndr)
+ then
+ -- This should really only happen at the top level... TODO: Give
+ -- a different error if this happens down in the recursion.
+ error $ "\nNormalize.normalizeBind: Function " ++ show bndr ++ " is polymorphic, can't normalize"
+ else do
+ expr <- getBinding bndr
+ normalizeExpr (show bndr) expr
+
+-- | Normalize an expression
+normalizeExpr ::
+ String -- ^ What are we normalizing? For debug output only.
+ -> CoreSyn.CoreExpr -- ^ The expression to normalize
+ -> TranslatorSession CoreSyn.CoreExpr -- ^ The normalized expression
+
+normalizeExpr what expr = do
+ -- Introduce an empty Let at the top level, so there will always be
+ -- a let in the expression (none of the transformations will remove
+ -- the last let).
+ let expr' = Let (Rec []) expr
+ -- Normalize this expression
+ trace ("Transforming " ++ what ++ "\nBefore:\n\n" ++ showSDoc ( ppr expr' ) ++ "\n") $ return ()
+ expr'' <- dotransforms transforms expr'
+ trace ("\nAfter:\n\n" ++ showSDoc ( ppr expr')) $ return ()
+ return expr''
+
+-- | Get the value that is bound to the given binder at top level. Fails when
+-- there is no such binding.
+getBinding ::
+ CoreBndr -- ^ The binder to get the expression for
+ -> TranslatorSession CoreExpr -- ^ The value bound to the binder
+
+getBinding bndr = Utils.makeCached bndr tsBindings $ do
+ -- 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
-- This module provides functions for program transformations.
--
module CLasH.Normalize.NormalizeTools where
+
-- Standard modules
import Debug.Trace
import qualified List
-- GHC API
import CoreSyn
-import qualified UniqSupply
-import qualified Unique
-import qualified OccName
-import qualified Name
-import qualified Var
-import qualified SrcLoc
-import qualified Type
-import qualified IdInfo
-import qualified CoreUtils
import qualified CoreSubst
-import qualified VarSet
-import qualified HscTypes
+import qualified CoreUtils
import Outputable ( showSDoc, ppr, nest )
-- Local imports
import CLasH.Normalize.NormalizeTypes
+import CLasH.Translator.TranslatorTypes
import CLasH.Utils.Pretty
import CLasH.VHDL.VHDLTypes
import qualified CLasH.VHDL.VHDLTools as VHDLTools
--- Create a new internal var with the given name and type. A Unique is
--- appended to the given name, to ensure uniqueness (not strictly neccesary,
--- since the Unique is also stored in the name, but this ensures variable
--- names are unique in the output).
-mkInternalVar :: String -> Type.Type -> TransformMonad Var.Var
-mkInternalVar str ty = Trans.lift (mkInternalVar' str ty)
-
-mkInternalVar' :: String -> Type.Type -> TransformSession Var.Var
-mkInternalVar' str ty = do
- uniq <- mkUnique'
- let occname = OccName.mkVarOcc (str ++ show uniq)
- let name = Name.mkInternalName uniq occname SrcLoc.noSrcSpan
- return $ Var.mkLocalVar IdInfo.VanillaId name ty IdInfo.vanillaIdInfo
-
--- Create a new type variable with the given name and kind. A Unique is
--- appended to the given name, to ensure uniqueness (not strictly neccesary,
--- since the Unique is also stored in the name, but this ensures variable
--- names are unique in the output).
-mkTypeVar :: String -> Type.Kind -> TransformMonad Var.Var
-mkTypeVar str kind = Trans.lift (mkTypeVar' str kind)
-
-mkTypeVar' :: String -> Type.Kind -> TransformSession Var.Var
-mkTypeVar' str kind = do
- uniq <- mkUnique'
- let occname = OccName.mkVarOcc (str ++ show uniq)
- let name = Name.mkInternalName uniq occname SrcLoc.noSrcSpan
- return $ Var.mkTyVar name kind
-
--- 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 -> TransformMonad Var.Var
-mkBinderFor expr string = Trans.lift (mkBinderFor' expr string)
-
-mkBinderFor' :: CoreExpr -> String -> TransformSession Var.Var
-mkBinderFor' (Type ty) string = mkTypeVar' string (Type.typeKind ty)
-mkBinderFor' expr string = mkInternalVar' string (CoreUtils.exprType expr)
-
--- Creates a reference to the given variable. This works for both a normal
--- variable as well as a type variable
-mkReferenceTo :: Var.Var -> CoreExpr
-mkReferenceTo var | Var.isTyVar var = (Type $ Type.mkTyVarTy var)
- | otherwise = (Var var)
-
-cloneVar :: Var.Var -> TransformMonad Var.Var
-cloneVar v = do
- uniq <- mkUnique
- -- Swap out the unique, and reset the IdInfo (I'm not 100% sure what it
- -- contains, but vannillaIdInfo is always correct, since it means "no info").
- return $ Var.lazySetIdInfo (Var.setVarUnique v uniq) IdInfo.vanillaIdInfo
-
--- 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 -> TransformMonad CoreBndr
-mkFunction bndr body = do
- let ty = CoreUtils.exprType body
- id <- cloneVar bndr
- let newid = Var.setVarType id ty
- Trans.lift $ addGlobalBind newid body
- return newid
-
-- Apply the given transformation to all expressions in the given expression,
-- including the expression itself.
everywhere :: (String, Transform) -> Transform
subnotappargs trans expr = subeverywhere (notappargs trans) expr
-- Runs each of the transforms repeatedly inside the State monad.
-dotransforms :: [Transform] -> CoreExpr -> TransformSession CoreExpr
+dotransforms :: [Transform] -> CoreExpr -> TranslatorSession CoreExpr
dotransforms transs expr = do
(expr', changed) <- Writer.runWriterT $ Monad.foldM (flip ($)) expr transs
if Monoid.getAny changed then dotransforms transs expr' else return expr'
setChanged
return val
--- Create a new Unique
-mkUnique :: TransformMonad Unique.Unique
-mkUnique = Trans.lift $ mkUnique'
-
-mkUnique' :: TransformSession Unique.Unique
-mkUnique' = do
- us <- getA tsUniqSupply
- let (us', us'') = UniqSupply.splitUniqSupply us
- putA tsUniqSupply us'
- return $ UniqSupply.uniqFromSupply us''
-
-- Replace each of the binders given with the coresponding expressions in the
-- given expression.
substitute :: [(CoreBndr, CoreExpr)] -> CoreExpr -> CoreExpr
-- substitutions
subss' = map (Arrow.second (CoreSubst.substExpr subs)) subss
--- Run a given TransformSession. Used mostly to setup the right calls and
--- an initial state.
-runTransformSession :: HscTypes.HscEnv -> UniqSupply.UniqSupply -> TransformSession a -> a
-runTransformSession env uniqSupply session = State.evalState session emptyTransformState
- where
- emptyTypeState = TypeState Map.empty [] Map.empty Map.empty env
- emptyTransformState = TransformState uniqSupply Map.empty VarSet.emptyVarSet emptyTypeState
-
-- Is the given expression representable at runtime, based on the type?
isRepr :: CoreSyn.CoreExpr -> TransformMonad Bool
isRepr (Type ty) = return False
isRepr expr = Trans.lift $ MonadState.lift tsType $ VHDLTools.isReprType (CoreUtils.exprType expr)
-is_local_var :: CoreSyn.CoreExpr -> TransformSession Bool
+is_local_var :: CoreSyn.CoreExpr -> TranslatorSession Bool
is_local_var (CoreSyn.Var v) = do
bndrs <- getGlobalBinders
return $ not $ v `elem` bndrs
-- GHC API
import CoreSyn
-import qualified UniqSupply
import qualified VarSet
import Outputable ( Outputable, showSDoc, ppr )
-- Local imports
import CLasH.Utils.Core.CoreShow
import CLasH.Utils.Pretty
-import CLasH.VHDL.VHDLTypes -- For TypeState
+import CLasH.Translator.TranslatorTypes
-data TransformState = TransformState {
- tsUniqSupply_ :: UniqSupply.UniqSupply
- , tsBindings_ :: Map.Map CoreBndr CoreExpr
- , tsNormalized_ :: VarSet.VarSet -- ^ The binders that have been normalized
- , tsType_ :: TypeState
-}
-
-$( Data.Accessor.Template.deriveAccessors ''TransformState )
-
--- A session of multiple transformations over multiple expressions
-type TransformSession = (State.State TransformState)
--- Wrap a writer around a TransformSession, to run a single transformation
+-- Wrap a writer around a TranslatorSession, to run a single transformation
-- over a single expression and track if the expression was changed.
-type TransformMonad = Writer.WriterT Monoid.Any TransformSession
+type TransformMonad = Writer.WriterT Monoid.Any TranslatorSession
-- | Transforms a CoreExpr and keeps track if it has changed.
type Transform = CoreExpr -> TransformMonad CoreExpr
-
--- Finds the value of a global binding, if available
-getGlobalBind :: CoreBndr -> TransformSession (Maybe CoreExpr)
-getGlobalBind bndr = do
- bindings <- getA tsBindings
- return $ Map.lookup bndr bindings
-
--- Adds a new global binding with the given value
-addGlobalBind :: CoreBndr -> CoreExpr -> TransformSession ()
-addGlobalBind bndr expr = modA tsBindings (Map.insert bndr expr)
-
--- Returns a list of all global binders
-getGlobalBinders :: TransformSession [CoreBndr]
-getGlobalBinders = do
- bindings <- getA tsBindings
- return $ Map.keys bindings
import qualified Maybe
import qualified Monad
import qualified System.FilePath as FilePath
+import qualified Control.Monad.Trans.State as State
import Text.PrettyPrint.HughesPJ (render)
+import Data.Accessor
+import qualified Data.Map as Map
-- GHC API
import qualified CoreSyn
-- 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.Testbench
-- | Turn Haskell to VHDL, Usings Strings to indicate the Top Entity, Initial
-- State and Test Inputs.
-> Bool -- ^ Is it stateful? (in case InitState is empty)
-> IO ()
makeVHDLStrings libdir filenames topentity initstate testinput stateful = do
- makeVHDL libdir filenames findTopEntity findInitState findTestInput stateful
+ makeVHDL libdir filenames finder stateful
where
- findTopEntity = findBind (hasVarName topentity)
- findInitState = findBind (hasVarName initstate)
- findTestInput = findExpr (hasVarName testinput)
+ finder = findSpec (hasVarName topentity)
+ (hasVarName initstate)
+ (hasVarName testinput)
-- | Turn Haskell to VHDL, Using the Annotations for Top Entity, Initial State
-- and Test Inputs found in the Files.
-> Bool -- ^ Is it stateful? (in case InitState is not specified)
-> IO ()
makeVHDLAnnotations libdir filenames stateful = do
- makeVHDL libdir filenames findTopEntity findInitState findTestInput stateful
+ makeVHDL libdir filenames finder stateful
where
- findTopEntity = findBind (hasCLasHAnnotation isTopEntity)
- findInitState = findBind (hasCLasHAnnotation isInitState)
- findTestInput = findExpr (hasCLasHAnnotation isTestInput)
+ finder = findSpec (hasCLasHAnnotation isTopEntity)
+ (hasCLasHAnnotation isInitState)
+ (hasCLasHAnnotation isTestInput)
-- | Turn Haskell to VHDL, using the given finder functions to find the Top
-- Entity, Initial State and Test Inputs in the Haskell Files.
makeVHDL ::
FilePath -- ^ The GHC Library Dir
-> [FilePath] -- ^ The Filenames
- -> (HscTypes.CoreModule -> GHC.Ghc (Maybe CoreSyn.CoreBndr)) -- ^ The Top Entity Finder
- -> (HscTypes.CoreModule -> GHC.Ghc (Maybe CoreSyn.CoreBndr)) -- ^ The Init State Finder
- -> (HscTypes.CoreModule -> GHC.Ghc (Maybe CoreSyn.CoreExpr)) -- ^ The Test Input Finder
+ -> Finder
-> Bool -- ^ Indicates if it is meant to be stateful
-> IO ()
-makeVHDL libdir filenames topEntFinder initStateFinder testInputFinder stateful = do
+makeVHDL libdir filenames finder stateful = do
-- Load the modules
- (cores, top, init, test, env) <- loadModules libdir filenames topEntFinder initStateFinder testInputFinder
+ (cores, env, specs) <- loadModules libdir filenames (Just finder)
-- Translate to VHDL
- vhdl <- moduleToVHDL env cores top init test stateful
- -- Write VHDL to file
- let top_entity = Maybe.fromJust $ head top
+ vhdl <- moduleToVHDL env cores specs stateful
+ -- Write VHDL to file. Just use the first entity for the name
+ let top_entity = (\(t, _, _) -> t) $ head specs
let dir = "./vhdl/" ++ (show top_entity) ++ "/"
prepareDir dir
mapM (writeVHDL dir) vhdl
moduleToVHDL ::
HscTypes.HscEnv -- ^ The GHC Environment
-> [HscTypes.CoreModule] -- ^ The Core Modules
- -> [Maybe CoreSyn.CoreBndr] -- ^ The TopEntity
- -> [Maybe CoreSyn.CoreBndr] -- ^ The InitState
- -> [Maybe CoreSyn.CoreExpr] -- ^ The TestInput
+ -> [EntitySpec] -- ^ The entities to generate
-> Bool -- ^ Is it stateful (in case InitState is not specified)
-> IO [(AST.VHDLId, AST.DesignFile)]
-moduleToVHDL env cores top init test stateful = do
- let topEntity = Maybe.catMaybes top
- case topEntity of
- [] -> error "Top Entity Not Found"
- [topEnt] -> do
- let initialState = Maybe.catMaybes init
- let isStateful = not (null initialState) || stateful
- let testInput = Maybe.catMaybes test
- -- Generate a UniqSupply
- -- Running
- -- egrep -r "(initTcRnIf|mkSplitUniqSupply)" .
- -- on the compiler dir of ghc suggests that 'z' is not used to generate
- -- a unique supply anywhere.
- uniqSupply <- UniqSupply.mkSplitUniqSupply 'z'
- let all_bindings = concat (map (\x -> CoreSyn.flattenBinds (HscTypes.cm_binds x)) cores)
- let testexprs = case testInput of [] -> [] ; [x] -> reduceCoreListToHsList x
- let (normalized_bindings, test_bindings, typestate) = normalizeModule env uniqSupply all_bindings testexprs [topEnt] [isStateful]
- let vhdl = createDesignFiles typestate normalized_bindings topEnt test_bindings
- mapM (putStr . render . Ppr.ppr . snd) vhdl
- return vhdl
- xs -> error "More than one topentity found"
+moduleToVHDL env cores specs stateful = do
+ vhdl <- runTranslatorSession env $ do
+ let all_bindings = concat (map (\x -> CoreSyn.flattenBinds (HscTypes.cm_binds x)) cores)
+ -- Store the bindings we loaded
+ tsBindings %= Map.fromList all_bindings
+ test_binds <- catMaybesM $ Monad.mapM mkTest specs
+ let topbinds = map (\(top, _, _) -> top) specs
+ createDesignFiles (topbinds ++ test_binds)
+ mapM (putStr . render . Ppr.ppr . snd) vhdl
+ return vhdl
+ where
+ mkTest :: EntitySpec -> TranslatorSession (Maybe CoreSyn.CoreBndr)
+ -- Create a testbench for any entry that has test input
+ mkTest (_, _, Nothing) = return Nothing
+ mkTest (top, _, Just input) = do
+ bndr <- createTestbench Nothing input top
+ return $ Just bndr
+
+-- Run the given translator session. Generates a new UniqSupply for that
+-- session.
+runTranslatorSession :: HscTypes.HscEnv -> TranslatorSession a -> IO a
+runTranslatorSession env session = do
+ -- Generate a UniqSupply
+ -- Running
+ -- egrep -r "(initTcRnIf|mkSplitUniqSupply)" .
+ -- on the compiler dir of ghc suggests that 'z' is not used to generate
+ -- a unique supply anywhere.
+ uniqSupply <- UniqSupply.mkSplitUniqSupply 'z'
+ let init_typestate = TypeState Map.empty [] Map.empty Map.empty env
+ let init_state = TranslatorState uniqSupply init_typestate Map.empty Map.empty Map.empty Map.empty
+ return $ State.evalState session init_state
-- | Prepares the directory for writing VHDL files. This means creating the
-- dir if it does not exist and removing all existing .vhdl files from it.
{-# LANGUAGE TemplateHaskell #-}
module CLasH.Translator.TranslatorTypes where
+-- Standard modules
import qualified Control.Monad.Trans.State as State
import qualified Data.Map as Map
import qualified Data.Accessor.Template
import Data.Accessor
+-- GHC API
+import qualified GHC
+import qualified CoreSyn
+import qualified Type
import qualified HscTypes
+import qualified UniqSupply
+-- ForSyDe
import qualified Language.VHDL.AST as AST
+-- Local imports
import CLasH.VHDL.VHDLTypes
-data TranslatorSession = TranslatorSession {
- tsCoreModule_ :: HscTypes.CoreModule, -- ^ The current module
- tsNameCount_ :: Int -- ^ A counter that can be used to generate unique names
+-- | 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
+-- test input.
+type EntitySpec = (CoreSyn.CoreBndr, Maybe CoreSyn.CoreExpr, Maybe CoreSyn.CoreExpr)
+
+-- | A function that knows which parts of a module to compile
+type Finder =
+ HscTypes.CoreModule -- ^ The module to look at
+ -> GHC.Ghc [EntitySpec]
+
+-----------------------------------------------------------------------------
+-- The TranslatorSession
+-----------------------------------------------------------------------------
+
+-- A orderable equivalent of CoreSyn's Type for use as a map key
+newtype OrdType = OrdType { getType :: Type.Type }
+instance Eq OrdType where
+ (OrdType a) == (OrdType b) = Type.tcEqType a b
+instance Ord OrdType where
+ compare (OrdType a) (OrdType b) = Type.tcCmpType a b
+
+data HType = StdType OrdType |
+ ADTType String [HType] |
+ VecType Int HType |
+ SizedWType Int |
+ RangedWType Int |
+ SizedIType Int |
+ BuiltinType String
+ deriving (Eq, Ord)
+
+-- A map of a Core type to the corresponding type name
+type TypeMap = Map.Map HType (AST.VHDLId, Either AST.TypeDef AST.SubtypeIn)
+
+-- A map of a vector Core element type and function name to the coressponding
+-- VHDLId of the function and the function body.
+type TypeFunMap = Map.Map (OrdType, String) (AST.VHDLId, AST.SubProgBody)
+
+type TfpIntMap = Map.Map OrdType Int
+-- A substate that deals with type generation
+data TypeState = TypeState {
+ -- | A map of Core type -> VHDL Type
+ tsTypes_ :: TypeMap,
+ -- | A list of type declarations
+ tsTypeDecls_ :: [AST.PackageDecItem],
+ -- | A map of vector Core type -> VHDL type function
+ tsTypeFuns_ :: TypeFunMap,
+ tsTfpInts_ :: TfpIntMap,
+ tsHscEnv_ :: HscTypes.HscEnv
+}
+
+-- Derive accessors
+$( Data.Accessor.Template.deriveAccessors ''TypeState )
+
+-- Define a session
+type TypeSession = State.State TypeState
+-- A global state for the translator
+data TranslatorState = TranslatorState {
+ tsUniqSupply_ :: UniqSupply.UniqSupply
+ , tsType_ :: TypeState
+ , tsBindings_ :: Map.Map CoreSyn.CoreBndr CoreSyn.CoreExpr
+ , tsNormalized_ :: Map.Map CoreSyn.CoreBndr CoreSyn.CoreExpr
+ , tsEntities_ :: Map.Map CoreSyn.CoreBndr Entity
+ , tsArchitectures_ :: Map.Map CoreSyn.CoreBndr (Architecture, [CoreSyn.CoreBndr])
}
-- Derive accessors
-$( Data.Accessor.Template.deriveAccessors ''TranslatorSession )
+$( Data.Accessor.Template.deriveAccessors ''TranslatorState )
+
+type TranslatorSession = State.State TranslatorState
+
+-----------------------------------------------------------------------------
+-- Some accessors
+-----------------------------------------------------------------------------
+
+-- Does the given binder reference a top level binder in the current
+-- module(s)?
+isTopLevelBinder :: CoreSyn.CoreBndr -> TranslatorSession Bool
+isTopLevelBinder bndr = do
+ bindings <- getA tsBindings
+ return $ Map.member bndr bindings
+
+-- Finds the value of a global binding, if available
+getGlobalBind :: CoreSyn.CoreBndr -> TranslatorSession (Maybe CoreSyn.CoreExpr)
+getGlobalBind bndr = do
+ bindings <- getA tsBindings
+ return $ Map.lookup bndr bindings
+
+-- Adds a new global binding with the given value
+addGlobalBind :: CoreSyn.CoreBndr -> CoreSyn.CoreExpr -> TranslatorSession ()
+addGlobalBind bndr expr = modA tsBindings (Map.insert bndr expr)
-type TranslatorState = State.State TranslatorSession
+-- Returns a list of all global binders
+getGlobalBinders :: TranslatorSession [CoreSyn.CoreBndr]
+getGlobalBinders = do
+ bindings <- getA tsBindings
+ return $ Map.keys bindings
-- vim: set ts=8 sw=2 sts=2 expandtab:
-module CLasH.Utils
- ( listBindings
- , listBind
- ) where
+module CLasH.Utils where
-- Standard Imports
import qualified Maybe
+import Data.Accessor
+import qualified Data.Map as Map
+import qualified Control.Monad as Monad
+import qualified Control.Monad.Trans.State as State
-- GHC API
-import qualified CoreSyn
-import qualified CoreUtils
-import qualified HscTypes
-import qualified Outputable
-import qualified Var
-- Local Imports
-import CLasH.Utils.GhcTools
-import CLasH.Utils.Pretty
-listBindings :: FilePath -> [FilePath] -> IO [()]
-listBindings libdir filenames = do
- (cores,_,_,_,_) <- loadModules libdir filenames bogusFinder bogusFinder bogusFinder
- let binds = concat $ map (CoreSyn.flattenBinds . HscTypes.cm_binds) cores
- mapM (listBinding) binds
- where
- bogusFinder = (\x -> return $ Nothing)
+-- Make a caching version of a stateful computatation.
+makeCached :: (Monad m, Ord k) =>
+ k -- ^ The key to use for the cache
+ -> Accessor s (Map.Map k v) -- ^ The accessor to get at the cache
+ -> State.StateT s m v -- ^ How to compute the value to cache?
+ -> State.StateT s m v -- ^ The resulting value, from the cache or freshly
+ -- computed.
+makeCached key accessor create = do
+ cache <- getA accessor
+ case Map.lookup key cache of
+ -- Found in cache, just return
+ Just value -> return value
+ -- Not found, compute it and put it in the cache
+ Nothing -> do
+ value <- create
+ modA accessor (Map.insert key value)
+ return value
+
+unzipM :: (Monad m) =>
+ m [(a, b)]
+ -> m ([a], [b])
+unzipM = Monad.liftM unzip
+
+catMaybesM :: (Monad m) =>
+ m [Maybe a]
+ -> m [a]
+catMaybesM = Monad.liftM Maybe.catMaybes
+
+concatM :: (Monad m) =>
+ m [[a]]
+ -> m [a]
+concatM = Monad.liftM concat
-listBinding :: (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -> IO ()
-listBinding (b, e) = do
- putStr "\nBinder: "
- putStr $ show b
- putStr "\nType of Binder: \n"
- putStr $ Outputable.showSDoc $ Outputable.ppr $ Var.varType b
- putStr "\n\nExpression: \n"
- putStr $ prettyShow e
- putStr "\n\n"
- putStr $ Outputable.showSDoc $ Outputable.ppr e
- putStr "\n\nType of Expression: \n"
- putStr $ Outputable.showSDoc $ Outputable.ppr $ CoreUtils.exprType e
- putStr "\n\n"
-
--- | Show the core structure of the given binds in the given file.
-listBind :: FilePath -> [FilePath] -> String -> IO ()
-listBind libdir filenames name = do
- (_,corebind,_,coreexpr,_) <- loadModules libdir filenames bindFinder bindFinder exprFinder
- listBinding (Maybe.fromJust $ head corebind, Maybe.fromJust $ head coreexpr)
- where
- bindFinder = findBind (hasVarName name)
- exprFinder = findExpr (hasVarName name)
\ No newline at end of file
--- /dev/null
+--
+-- This module contains functions that manipulate binders in various ways.
+--
+module CLasH.Utils.Core.BinderTools where
+
+-- Standard modules
+import Data.Accessor.MonadState as MonadState
+
+-- GHC API
+import CoreSyn
+import qualified Type
+import qualified UniqSupply
+import qualified Unique
+import qualified OccName
+import qualified Name
+import qualified Var
+import qualified SrcLoc
+import qualified IdInfo
+import qualified CoreUtils
+import qualified CoreSubst
+import qualified VarSet
+import qualified HscTypes
+
+-- Local imports
+import Data.Accessor
+import Data.Accessor.MonadState as MonadState
+import CLasH.Translator.TranslatorTypes
+
+-- Create a new Unique
+mkUnique :: TranslatorSession Unique.Unique
+mkUnique = do
+ us <- getA tsUniqSupply
+ let (us', us'') = UniqSupply.splitUniqSupply us
+ putA tsUniqSupply us'
+ return $ UniqSupply.uniqFromSupply us''
+
+-- Create a new internal var with the given name and type. A Unique is
+-- appended to the given name, to ensure uniqueness (not strictly neccesary,
+-- since the Unique is also stored in the name, but this ensures variable
+-- names are unique in the output).
+mkInternalVar :: String -> Type.Type -> TranslatorSession Var.Var
+mkInternalVar str ty = do
+ uniq <- mkUnique
+ let occname = OccName.mkVarOcc (str ++ show uniq)
+ let name = Name.mkInternalName uniq occname SrcLoc.noSrcSpan
+ return $ Var.mkLocalVar IdInfo.VanillaId name ty IdInfo.vanillaIdInfo
+
+-- Create a new type variable with the given name and kind. A Unique is
+-- appended to the given name, to ensure uniqueness (not strictly neccesary,
+-- since the Unique is also stored in the name, but this ensures variable
+-- names are unique in the output).
+mkTypeVar :: String -> Type.Kind -> TranslatorSession Var.Var
+mkTypeVar str kind = do
+ uniq <- mkUnique
+ let occname = OccName.mkVarOcc (str ++ show uniq)
+ let name = Name.mkInternalName uniq occname SrcLoc.noSrcSpan
+ return $ Var.mkTyVar name kind
+
+-- 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 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)
+
+cloneVar :: Var.Var -> TranslatorSession Var.Var
+cloneVar v = do
+ uniq <- mkUnique
+ -- Swap out the unique, and reset the IdInfo (I'm not 100% sure what it
+ -- contains, but vannillaIdInfo is always correct, since it means "no info").
+ return $ Var.lazySetIdInfo (Var.setVarUnique v uniq) IdInfo.vanillaIdInfo
+
+-- 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 bndr body = do
+ let ty = CoreUtils.exprType body
+ id <- cloneVar bndr
+ let newid = Var.setVarType id ty
+ addGlobalBind newid body
+ return newid
-- GHC API
import qualified Annotations
import qualified CoreSyn
+import qualified CoreUtils
import qualified DynFlags
import qualified HscTypes
import qualified GHC
import qualified Name
import qualified Serialized
import qualified Var
+import qualified Outputable
-- Local Imports
+import CLasH.Utils.Pretty
+import CLasH.Translator.TranslatorTypes
import CLasH.Translator.Annotations
+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
+
+listBinding :: (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -> IO ()
+listBinding (b, e) = do
+ putStr "\nBinder: "
+ putStr $ show b
+ putStr "\nType of Binder: \n"
+ putStr $ Outputable.showSDoc $ Outputable.ppr $ Var.varType b
+ putStr "\n\nExpression: \n"
+ putStr $ prettyShow e
+ putStr "\n\n"
+ putStr $ Outputable.showSDoc $ Outputable.ppr e
+ putStr "\n\nType of Expression: \n"
+ putStr $ Outputable.showSDoc $ Outputable.ppr $ CoreUtils.exprType e
+ putStr "\n\n"
+
+-- | Show the core structure of the given binds in the given file.
+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
+ return ()
-- Change a DynFlag from within the Ghc monad. Strangely enough there seems to
-- be no standard function to do exactly this.
loadModules ::
FilePath -- ^ The GHC Library directory
-> [String] -- ^ The files that need to be loaded
- -> (HscTypes.CoreModule -> GHC.Ghc (Maybe CoreSyn.CoreBndr)) -- ^ The TopEntity finder
- -> (HscTypes.CoreModule -> GHC.Ghc (Maybe CoreSyn.CoreBndr)) -- ^ The InitState finder
- -> (HscTypes.CoreModule -> GHC.Ghc (Maybe CoreSyn.CoreExpr)) -- ^ The TestInput finder
+ -> Maybe Finder -- ^ What entities to build?
-> IO ( [HscTypes.CoreModule]
- , [Maybe CoreSyn.CoreBndr]
- , [Maybe CoreSyn.CoreBndr]
- , [Maybe CoreSyn.CoreExpr]
, HscTypes.HscEnv
- ) -- ^ ( The loaded modules, the TopEntity, the InitState, the TestInput
- -- , The Environment corresponding of the loaded modules
- -- )
-loadModules libdir filenames topEntLoc initSLoc testLoc =
+ , [EntitySpec]
+ ) -- ^ ( The loaded modules, the resulting ghc environment, the entities to build)
+loadModules libdir filenames finder =
GHC.defaultErrorHandler DynFlags.defaultDynFlags $ do
GHC.runGhc (Just libdir) $ do
dflags <- GHC.getSessionDynFlags
GHC.setSessionDynFlags dflags
cores <- mapM GHC.compileToCoreModule filenames
env <- GHC.getSession
- top_entity <- mapM topEntLoc cores
- init_state <- mapM initSLoc cores
- test_input <- mapM testLoc cores
- return (cores, top_entity, init_state, test_input, env)
+ specs <- case finder of
+ Nothing -> return []
+ Just f -> concatM $ mapM f cores
+ return (cores, env, specs)
findBind ::
- GHC.GhcMonad m =>
+ Monad m =>
(Var.Var -> m Bool)
-> HscTypes.CoreModule
-> m (Maybe CoreSyn.CoreBndr)
bndrs -> return $ Just $ fst $ head bndrs
findExpr ::
- GHC.GhcMonad m =>
+ Monad m =>
(Var.Var -> m Bool)
-> HscTypes.CoreModule
-> m (Maybe CoreSyn.CoreExpr)
-- | Find a binder in module according to a certain criteria
findBinder ::
- GHC.GhcMonad m =>
+ Monad m =>
(Var.Var -> m Bool) -- ^ The criteria to filter the binders on
-> HscTypes.CoreModule -- ^ The module to be inspected
-> m [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)] -- ^ The binders to meet the criteria
-- | Determine if a binder has a certain name
hasVarName ::
- GHC.GhcMonad m =>
+ Monad m =>
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)
+
+-- | Make a complete spec out of a three conditions
+findSpec ::
+ (Var.Var -> GHC.Ghc Bool) -> (Var.Var -> GHC.Ghc Bool) -> (Var.Var -> GHC.Ghc Bool)
+ -> Finder
+
+findSpec topc statec testc mod = do
+ top <- findBind topc mod
+ state <- findExpr statec mod
+ test <- findExpr testc mod
+ case top of
+ Just t -> return [(t, state, test)]
+ Nothing -> error $ "Could not find top entity requested"
printList :: (a -> Doc) -> [a] -> Doc
printList f = brackets . fsep . punctuate comma . map f
-instance Pretty TranslatorSession where
- pPrint (TranslatorSession mod nameCount) =
- text "Module: " $$ nest 15 (text modname)
- $+$ text "NameCount: " $$ nest 15 (int nameCount)
- where
- ppfunc (hsfunc, flatfunc) =
- pPrint hsfunc $+$ nest 5 (pPrint flatfunc)
- modname = showSDoc $ Module.pprModule (HscTypes.cm_module mod)
{-
instance Pretty FuncData where
pPrint (FuncData flatfunc entity arch) =
-}
instance Pretty Entity where
- pPrint (Entity id args res) =
+ pPrint (Entity id args res decl) =
text "Entity: " $$ nest 10 (pPrint id)
$+$ text "Args: " $$ nest 10 (pPrint args)
$+$ text "Result: " $$ nest 10 (pPrint res)
+ $+$ text "Declaration not shown"
instance (OutputableBndr b, Show b) => Pretty (CoreSyn.Bind b) where
pPrint (CoreSyn.NonRec b expr) =
module CLasH.VHDL where
-- Standard modules
-import qualified Data.List as List
import qualified Data.Map as Map
import qualified Maybe
import qualified Control.Monad as Monad
--import qualified Type
import qualified Name
import qualified Var
-import qualified Id
import qualified IdInfo
import qualified TyCon
import qualified DataCon
import Outputable ( showSDoc, ppr )
-- 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
+import CLasH.VHDL.Testbench
createDesignFiles ::
- TypeState
- -> [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)]
- -> CoreSyn.CoreBndr -- ^ Top binder
- -> [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)] -- ^ Test Input
- -> [(AST.VHDLId, AST.DesignFile)]
-
-createDesignFiles init_typestate binds topbind testinput =
- (mkVHDLBasicId "types", AST.DesignFile ieee_context [type_package_dec, type_package_body]) :
- map (Arrow.second $ AST.DesignFile full_context) (units ++ [testbench])
-
+ [CoreSyn.CoreBndr] -- ^ Top binders
+ -> TranslatorSession [(AST.VHDLId, AST.DesignFile)]
+
+createDesignFiles topbndrs = do
+ bndrss <- mapM recurseArchitectures topbndrs
+ let bndrs = concat bndrss
+ lunits <- mapM createLibraryUnit bndrs
+ typepackage <- createTypesPackage
+ let files = map (Arrow.second $ AST.DesignFile full_context) lunits
+ return $ typepackage : files
where
- init_session = VHDLState init_typestate Map.empty
- (units, final_session') =
- State.runState (createLibraryUnits binds) init_session
- (testbench, final_session) =
- State.runState (createTestBench Nothing testinput topbind) final_session'
- tyfun_decls = mkBuiltInShow ++ (map snd $ Map.elems (final_session ^. vsType ^. vsTypeFuns))
- ty_decls = final_session ^. vsType ^. vsTypeDecls
- tfvec_index_decl = AST.PDISD $ AST.SubtypeDec tfvec_indexTM tfvec_index_def
- tfvec_range = AST.ConstraintRange $ AST.SubTypeRange (AST.PrimLit "-1") (AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerTM) (AST.NSimple $ highId) Nothing)
- tfvec_index_def = AST.SubtypeIn integerTM (Just tfvec_range)
- ieee_context = [
- AST.Library $ mkVHDLBasicId "IEEE",
- mkUseAll ["IEEE", "std_logic_1164"],
- mkUseAll ["IEEE", "numeric_std"],
- mkUseAll ["std", "textio"]
- ]
full_context =
mkUseAll ["work", "types"]
: (mkUseAll ["work"]
: ieee_context)
- type_package_dec = AST.LUPackageDec $ AST.PackageDec (mkVHDLBasicId "types") ([tfvec_index_decl] ++ ty_decls ++ subProgSpecs)
- type_package_body = AST.LUPackageBody $ AST.PackageBody typesId tyfun_decls
- subProgSpecs = map subProgSpec tyfun_decls
- subProgSpec = \(AST.SubProgBody spec _ _) -> AST.PDISS spec
+
+ieee_context = [
+ AST.Library $ mkVHDLBasicId "IEEE",
+ mkUseAll ["IEEE", "std_logic_1164"],
+ mkUseAll ["IEEE", "numeric_std"],
+ mkUseAll ["std", "textio"]
+ ]
+
+-- | Find out which entities are needed for the given top level binders.
+recurseArchitectures ::
+ CoreSyn.CoreBndr -- ^ The top level binder
+ -> TranslatorSession [CoreSyn.CoreBndr]
+ -- ^ The binders of all needed functions.
+recurseArchitectures bndr = do
+ -- See what this binder directly uses
+ (_, used) <- getArchitecture bndr
+ -- Recursively check what each of the used functions uses
+ useds <- mapM recurseArchitectures used
+ -- And return all of them
+ return $ bndr : (concat useds)
+
+-- | Creates the types package, based on the current type state.
+createTypesPackage ::
+ TranslatorSession (AST.VHDLId, AST.DesignFile)
+ -- ^ The id and content of the types package
+
+createTypesPackage = do
+ tyfuns <- getA (tsType .> tsTypeFuns)
+ let tyfun_decls = mkBuiltInShow ++ (map snd $ Map.elems tyfuns)
+ ty_decls <- getA (tsType .> tsTypeDecls)
+ 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])
+ 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_index_def = AST.SubtypeIn integerTM (Just tfvec_range)
-- Create a use foo.bar.all statement. Takes a list of components in the used
-- name. Must contain at least two components
from = foldl select base_prefix (tail ss)
select prefix s = AST.NSelected $ prefix AST.:.: (AST.SSimple $ mkVHDLBasicId s)
-createLibraryUnits ::
- [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)]
- -> VHDLSession [(AST.VHDLId, [AST.LibraryUnit])]
+createLibraryUnit ::
+ CoreSyn.CoreBndr
+ -> TranslatorSession (AST.VHDLId, [AST.LibraryUnit])
-createLibraryUnits binds = do
- entities <- Monad.mapM createEntity binds
- archs <- Monad.mapM createArchitecture binds
- return $ zipWith
- (\ent arch ->
- let AST.EntityDec id _ = ent in
- (id, [AST.LUEntity ent, AST.LUArch arch])
- )
- entities archs
-
--- | Create an entity for a given function
-createEntity ::
- (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The function
- -> VHDLSession AST.EntityDec -- ^ The resulting entity
-
-createEntity (fname, expr) = do
- -- Strip off lambda's, these will be arguments
- let (args, letexpr) = CoreSyn.collectBinders expr
- args' <- Monad.mapM mkMap args
- -- There must be a let at top level
- let (CoreSyn.Let binds (CoreSyn.Var res)) = letexpr
- res' <- mkMap res
- let vhdl_id = mkVHDLBasicId $ varToString fname ++ "_" ++ varToStringUniq fname
- let ent_decl' = createEntityAST vhdl_id args' res'
- let AST.EntityDec entity_id _ = ent_decl'
- let signature = Entity entity_id args' res'
- modA vsSignatures (Map.insert fname signature)
- return ent_decl'
- where
- mkMap ::
- --[(SignalId, SignalInfo)]
- CoreSyn.CoreBndr
- -> VHDLSession Port
- -- We only need the vsTypes element from the state
- mkMap = (\bndr ->
- let
- --info = Maybe.fromMaybe
- -- (error $ "Signal not found in the name map? This should not happen!")
- -- (lookup id sigmap)
- -- Assume the bndr has a valid VHDL id already
- id = varToVHDLId bndr
- ty = Var.varType bndr
- error_msg = "\nVHDL.createEntity.mkMap: Can not create entity: " ++ pprString fname ++ "\nbecause no type can be created for port: " ++ pprString bndr
- in do
- type_mark <- MonadState.lift vsType $ vhdl_ty error_msg ty
- return (id, type_mark)
- )
-
--- | Create the VHDL AST for an entity
-createEntityAST ::
- AST.VHDLId -- ^ The name of the function
- -> [Port] -- ^ The entity's arguments
- -> Port -- ^ The entity's result
- -> AST.EntityDec -- ^ The entity with the ent_decl filled in as well
-
-createEntityAST vhdl_id args res =
- AST.EntityDec vhdl_id ports
- where
- -- Create a basic Id, since VHDL doesn't grok filenames with extended Ids.
- ports = map (mkIfaceSigDec AST.In) args
- ++ [mkIfaceSigDec AST.Out res]
- ++ [clk_port]
- -- Add a clk port if we have state
- clk_port = AST.IfaceSigDec clockId AST.In std_logicTM
-
--- | Create a port declaration
-mkIfaceSigDec ::
- AST.Mode -- ^ The mode for the port (In / Out)
- -> (AST.VHDLId, AST.TypeMark) -- ^ The id and type for the port
- -> AST.IfaceSigDec -- ^ The resulting port declaration
-
-mkIfaceSigDec mode (id, ty) = AST.IfaceSigDec id mode ty
-
-{-
--- | Generate a VHDL entity name for the given hsfunc
-mkEntityId hsfunc =
- -- TODO: This doesn't work for functions with multiple signatures!
- -- Use a Basic Id, since using extended id's for entities throws off
- -- precision and causes problems when generating filenames.
- mkVHDLBasicId $ hsFuncName hsfunc
--}
-
--- | Create an architecture for a given function
-createArchitecture ::
- (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The function
- -> VHDLSession AST.ArchBody -- ^ The architecture for this function
-
-createArchitecture (fname, expr) = do
- signaturemap <- getA vsSignatures
- let signature = Maybe.fromMaybe
- (error $ "\nVHDL.createArchitecture: Generating architecture for function \n" ++ (pprString fname) ++ "\nwithout signature? This should not happen!")
- (Map.lookup fname signaturemap)
- let entity_id = ent_id signature
- -- Strip off lambda's, these will be arguments
- let (args, letexpr) = CoreSyn.collectBinders expr
- -- There must be a let at top level
- let (CoreSyn.Let (CoreSyn.Rec binds) (Var res)) = letexpr
-
- -- Create signal declarations for all binders in the let expression, except
- -- 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
-
- statementss <- Monad.mapM mkConcSm binds
- let statements = concat statementss
- return $ AST.ArchBody (mkVHDLBasicId "structural") (AST.NSimple entity_id) (map AST.BDISD sig_decs) (statements ++ procs')
- where
- procs = [] --map mkStateProcSm [] -- (makeStatePairs flatfunc)
- procs' = map AST.CSPSm procs
- -- mkSigDec only uses vsTypes from the state
- mkSigDec' = mkSigDec
+createLibraryUnit bndr = do
+ entity <- getEntity bndr
+ (arch, _) <- getArchitecture bndr
+ return (ent_id entity, [AST.LUEntity (ent_dec entity), AST.LUArch arch])
{-
-- | Looks up all pairs of old state, new state signals, together with
(error $ "Unnamed signal? This should not happen!")
(sigName info)
-}
-
--- | Transforms a core binding into a VHDL concurrent statement
-mkConcSm ::
- (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The binding to process
- -> VHDLSession [AST.ConcSm] -- ^ The corresponding VHDL component instantiations.
-
-
--- Ignore Cast expressions, they should not longer have any meaning as long as
--- the type works out.
-mkConcSm (bndr, 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, Var v) = do
- genApplication (Left bndr) v []
-
-mkConcSm (bndr, app@(CoreSyn.App _ _))= do
- let (CoreSyn.Var f, args) = CoreSyn.collectArgs app
- let valargs = get_val_args (Var.varType f) args
- genApplication (Left bndr) f (map Left valargs)
-
--- A single alt case must be a selector. This means thee scrutinee is a simple
--- variable, the alternative is a dataalt with a single non-wild binder that
--- is also returned.
-mkConcSm (bndr, expr@(Case (Var scrut) b ty [alt])) =
- case alt of
- (DataAlt dc, bndrs, (Var sel_bndr)) -> do
- case List.elemIndex sel_bndr bndrs of
- Just i -> do
- labels <- MonadState.lift vsType $ getFieldLabels (Id.idType scrut)
- let label = labels!!i
- let sel_name = mkSelectedName (varToVHDLName scrut) label
- let sel_expr = AST.PrimName sel_name
- return [mkUncondAssign (Left bndr) sel_expr]
- Nothing -> error $ "\nVHDL.mkConcSM: Not in normal form: Not a selector case:\n" ++ (pprString expr)
-
- _ -> error $ "\nVHDL.mkConcSM: Not in normal form: Not a selector case:\n" ++ (pprString expr)
-
--- Multiple case alt are be conditional assignments and have only wild
--- binders in the alts and only variables in the case values and a variable
--- for a scrutinee. We check the constructor of the second alt, since the
--- first is the default case, if there is any.
-mkConcSm (bndr, (Case (Var scrut) b ty [(_, _, Var false), (con, _, Var true)])) = do
- scrut' <- MonadState.lift vsType $ varToVHDLExpr scrut
- let cond_expr = scrut' AST.:=: (altconToVHDLExpr con)
- true_expr <- MonadState.lift vsType $ varToVHDLExpr true
- false_expr <- MonadState.lift vsType $ varToVHDLExpr false
- return [mkCondAssign (Left bndr) cond_expr true_expr false_expr]
-
-mkConcSm (_, (Case (Var _) _ _ alts)) = error "\nVHDL.mkConcSm: Not in normal form: Case statement with more than two alternatives"
-mkConcSm (_, Case _ _ _ _) = error "\nVHDL.mkConcSm: Not in normal form: Case statement has does not have a simple variable as scrutinee"
-mkConcSm (bndr, expr) = error $ "\nVHDL.mkConcSM: Unsupported binding in let expression: " ++ pprString bndr ++ " = " ++ pprString expr
-
-
-createTestBench ::
- Maybe Int -- ^ Number of cycles to simulate
- -> [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)] -- ^ Input stimuli
- -> CoreSyn.CoreBndr -- ^ Top Entity
- -> VHDLSession (AST.VHDLId, [AST.LibraryUnit]) -- ^ Testbench
-createTestBench mCycles stimuli topEntity = do
- ent@(AST.EntityDec id _) <- createTestBenchEntity topEntity
- arch <- createTestBenchArch mCycles stimuli topEntity
- return (id, [AST.LUEntity ent, AST.LUArch arch])
-
-
-createTestBenchEntity ::
- CoreSyn.CoreBndr -- ^ Top Entity
- -> VHDLSession AST.EntityDec -- ^ TB Entity
-createTestBenchEntity topEntity = do
- signaturemap <- getA vsSignatures
- let signature = Maybe.fromMaybe
- (error $ "\nTestbench.createTestBenchEntity: Generating testbench for function \n" ++ (pprString topEntity) ++ "\nwithout signature? This should not happen!")
- (Map.lookup topEntity signaturemap)
- let signaturename = ent_id signature
- return $ AST.EntityDec (AST.unsafeIdAppend signaturename "_tb") []
-
-createTestBenchArch ::
- Maybe Int -- ^ Number of cycles to simulate
- -> [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)] -- ^ Imput stimulie
- -> CoreSyn.CoreBndr -- ^ Top Entity
- -> VHDLSession AST.ArchBody
-createTestBenchArch mCycles stimuli topEntity = do
- signaturemap <- getA vsSignatures
- let signature = Maybe.fromMaybe
- (error $ "\nTestbench.createTestBenchArch: Generating testbench for function \n" ++ (pprString topEntity) ++ "\nwithout signature? This should not happen!")
- (Map.lookup topEntity signaturemap)
- let entId = ent_id signature
- iIface = ent_args signature
- oIface = ent_res signature
- iIds = map fst iIface
- oIds = fst oIface
- let iDecs = map (\(vId, tm) -> AST.SigDec vId tm Nothing) iIface
- let finalIDecs = iDecs ++
- [AST.SigDec clockId std_logicTM (Just $ AST.PrimLit "'0'"),
- AST.SigDec resetId std_logicTM (Just $ AST.PrimLit "'0'")]
- let oDecs = AST.SigDec (fst oIface) (snd oIface) Nothing
- let portmaps = mkAssocElems (map idToVHDLExpr iIds) (AST.NSimple oIds) signature
- let mIns = mkComponentInst "totest" entId portmaps
- (stimuliAssigns, stimuliDecs, cycles) <- createStimuliAssigns mCycles stimuli (head iIds)
- let finalAssigns = (AST.CSSASm (AST.NSimple resetId AST.:<==:
- AST.ConWforms []
- (AST.Wform [AST.WformElem (AST.PrimLit "'1'") (Just $ AST.PrimLit "3 ns")])
- Nothing)) : stimuliAssigns
- let clkProc = createClkProc
- let outputProc = createOutputProc [oIds]
- return $ (AST.ArchBody
- (AST.unsafeVHDLBasicId "test")
- (AST.NSimple $ AST.unsafeIdAppend entId "_tb")
- (map AST.BDISD (finalIDecs ++ stimuliDecs ++ [oDecs]))
- (mIns :
- ( (AST.CSPSm clkProc) : (AST.CSPSm outputProc) : finalAssigns ) ) )
-
-createStimuliAssigns ::
- Maybe Int -- ^ Number of cycles to simulate
- -> [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)] -- ^ Input stimuli
- -> AST.VHDLId -- ^ Input signal
- -> VHDLSession ([AST.ConcSm], [AST.SigDec], Int)
-createStimuliAssigns mCycles [] _ = return ([], [], Maybe.maybe 0 id mCycles)
-
-createStimuliAssigns mCycles stimuli signal = do
- let genWformElem time stim = (AST.WformElem stim (Just $ AST.PrimLit (show time ++ " ns")))
- let inputlen = length stimuli
- assigns <- Monad.zipWithM createStimulans stimuli [0..inputlen]
- let resvars = (map snd assigns)
- sig_dec_maybes <- mapM mkSigDec resvars
- let sig_decs = Maybe.catMaybes sig_dec_maybes
- outps <- mapM (\x -> MonadState.lift vsType (varToVHDLExpr x)) resvars
- let wformelems = zipWith genWformElem [0,10..] outps
- let inassign = AST.CSSASm $ AST.NSimple signal AST.:<==: AST.ConWforms [] (AST.Wform wformelems) Nothing
- return ((map fst assigns) ++ [inassign], sig_decs, inputlen)
-
-createStimulans :: (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -> Int -> VHDLSession (AST.ConcSm, Var.Var)
-createStimulans (bndr, expr) cycl = do
- -- There must be a let at top level
- let (CoreSyn.Let (CoreSyn.Rec binds) (Var res)) = expr
- stimulansbinds <- Monad.mapM mkConcSm binds
- sig_dec_maybes <- mapM (mkSigDec . fst) (filter ((/=res).fst) binds)
- let sig_decs = map (AST.BDISD) (Maybe.catMaybes $ sig_dec_maybes)
- let block_label = mkVHDLExtId ("testcycle_" ++ (show cycl))
- let block = AST.BlockSm block_label [] (AST.PMapAspect []) sig_decs (concat stimulansbinds)
- return (AST.CSBSm block, res)
-
--- | generates a clock process with a period of 10ns
-createClkProc :: AST.ProcSm
-createClkProc = AST.ProcSm (AST.unsafeVHDLBasicId "clkproc") [] sms
- where sms = -- wait for 5 ns -- (half a cycle)
- [AST.WaitFor $ AST.PrimLit "5 ns",
- -- clk <= not clk;
- AST.NSimple clockId `AST.SigAssign`
- AST.Wform [AST.WformElem (AST.Not (AST.PrimName $ AST.NSimple clockId)) Nothing]]
-
--- | generate the output process
-createOutputProc :: [AST.VHDLId] -- ^ output signal
- -> AST.ProcSm
-createOutputProc outs =
- AST.ProcSm (AST.unsafeVHDLBasicId "writeoutput")
- [clockId]
- [AST.IfSm clkPred (writeOuts outs) [] Nothing]
- where clkPred = AST.PrimName (AST.NAttribute $ AST.AttribName (AST.NSimple clockId)
- (AST.NSimple $ eventId)
- Nothing ) `AST.And`
- (AST.PrimName (AST.NSimple clockId) AST.:=: AST.PrimLit "'1'")
- writeOuts :: [AST.VHDLId] -> [AST.SeqSm]
- writeOuts [] = []
- writeOuts [i] = [writeOut i (AST.PrimLit "LF")]
- writeOuts (i:is) = writeOut i (AST.PrimLit "HT") : writeOuts is
- writeOut outSig suffix =
- genExprPCall2 writeId
- (AST.PrimName $ AST.NSimple outputId)
- ((genExprFCall showId (AST.PrimName $ AST.NSimple outSig)) AST.:&: suffix)
module CLasH.VHDL.Generate where
-- Standard modules
+import qualified Data.List as List
import qualified Data.Map as Map
+import qualified Control.Monad as Monad
import qualified Maybe
import qualified Data.Either as Either
import Data.Accessor
import qualified CoreSyn
import qualified Type
import qualified Var
+import qualified Id
import qualified IdInfo
import qualified Literal
import qualified Name
import qualified TyCon
-- Local imports
+import CLasH.Translator.TranslatorTypes
import CLasH.VHDL.Constants
import CLasH.VHDL.VHDLTypes
import CLasH.VHDL.VHDLTools
+import qualified CLasH.Utils as Utils
import CLasH.Utils.Core.CoreTools
import CLasH.Utils.Pretty
+import qualified CLasH.Normalize as Normalize
+
+-----------------------------------------------------------------------------
+-- Functions to generate VHDL for user-defined functions.
+-----------------------------------------------------------------------------
+
+-- | Create an entity for a given function
+getEntity ::
+ CoreSyn.CoreBndr
+ -> TranslatorSession Entity -- ^ The resulting entity
+
+getEntity fname = Utils.makeCached fname tsEntities $ do
+ expr <- Normalize.getNormalized fname
+ -- Strip off lambda's, these will be arguments
+ let (args, letexpr) = CoreSyn.collectBinders expr
+ args' <- mapM mkMap args
+ -- There must be a let at top level
+ let (CoreSyn.Let binds (CoreSyn.Var res)) = letexpr
+ res' <- mkMap res
+ let vhdl_id = mkVHDLBasicId $ varToString fname ++ "_" ++ varToStringUniq fname
+ let ent_decl = createEntityAST vhdl_id args' res'
+ let signature = Entity vhdl_id args' res' ent_decl
+ return signature
+ where
+ mkMap ::
+ --[(SignalId, SignalInfo)]
+ CoreSyn.CoreBndr
+ -> TranslatorSession Port
+ mkMap = (\bndr ->
+ let
+ --info = Maybe.fromMaybe
+ -- (error $ "Signal not found in the name map? This should not happen!")
+ -- (lookup id sigmap)
+ -- Assume the bndr has a valid VHDL id already
+ id = varToVHDLId bndr
+ ty = Var.varType bndr
+ error_msg = "\nVHDL.createEntity.mkMap: Can not create entity: " ++ pprString fname ++ "\nbecause no type can be created for port: " ++ pprString bndr
+ in do
+ type_mark <- MonadState.lift tsType $ vhdl_ty error_msg ty
+ return (id, type_mark)
+ )
+
+-- | Create the VHDL AST for an entity
+createEntityAST ::
+ AST.VHDLId -- ^ The name of the function
+ -> [Port] -- ^ The entity's arguments
+ -> Port -- ^ The entity's result
+ -> AST.EntityDec -- ^ The entity with the ent_decl filled in as well
+
+createEntityAST vhdl_id args res =
+ AST.EntityDec vhdl_id ports
+ where
+ -- Create a basic Id, since VHDL doesn't grok filenames with extended Ids.
+ ports = map (mkIfaceSigDec AST.In) args
+ ++ [mkIfaceSigDec AST.Out res]
+ ++ [clk_port]
+ -- Add a clk port if we have state
+ clk_port = AST.IfaceSigDec clockId AST.In std_logicTM
+
+-- | Create a port declaration
+mkIfaceSigDec ::
+ AST.Mode -- ^ The mode for the port (In / Out)
+ -> (AST.VHDLId, AST.TypeMark) -- ^ The id and type for the port
+ -> AST.IfaceSigDec -- ^ The resulting port declaration
+
+mkIfaceSigDec mode (id, ty) = AST.IfaceSigDec id mode ty
+
+-- | Create an architecture for a given function
+getArchitecture ::
+ CoreSyn.CoreBndr -- ^ The function to get an architecture for
+ -> TranslatorSession (Architecture, [CoreSyn.CoreBndr])
+ -- ^ The architecture for this function
+
+getArchitecture fname = Utils.makeCached fname tsArchitectures $ do
+ expr <- Normalize.getNormalized fname
+ signature <- getEntity fname
+ let entity_id = ent_id signature
+ -- Strip off lambda's, these will be arguments
+ let (args, letexpr) = CoreSyn.collectBinders expr
+ -- There must be a let at top level
+ let (CoreSyn.Let (CoreSyn.Rec binds) (CoreSyn.Var res)) = letexpr
+
+ -- Create signal declarations for all binders in the let expression, except
+ -- 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
+
+ (statementss, used_entitiess) <- Monad.mapAndUnzipM mkConcSm binds
+ let statements = concat statementss
+ let used_entities = concat used_entitiess
+ let arch = AST.ArchBody (mkVHDLBasicId "structural") (AST.NSimple entity_id) (map AST.BDISD sig_decs) (statements ++ procs')
+ return (arch, used_entities)
+ where
+ procs = [] --map mkStateProcSm [] -- (makeStatePairs flatfunc)
+ procs' = map AST.CSPSm procs
+ -- mkSigDec only uses tsTypes from the state
+ mkSigDec' = mkSigDec
+
+-- | Transforms a core binding into a VHDL concurrent statement
+mkConcSm ::
+ (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The binding to process
+ -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
+ -- ^ The corresponding VHDL concurrent statements and entities
+ -- instantiated.
+
+
+-- Ignore Cast expressions, they should not longer have any meaning as long as
+-- the type works out.
+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
+ genApplication (Left bndr) v []
+
+mkConcSm (bndr, app@(CoreSyn.App _ _))= do
+ let (CoreSyn.Var f, args) = CoreSyn.collectArgs app
+ let valargs = get_val_args (Var.varType f) args
+ genApplication (Left bndr) f (map Left valargs)
+
+-- A single alt case must be a selector. This means thee scrutinee is a simple
+-- variable, the alternative is a dataalt with a single non-wild binder that
+-- is also returned.
+mkConcSm (bndr, expr@(CoreSyn.Case (CoreSyn.Var scrut) b ty [alt])) =
+ case alt of
+ (CoreSyn.DataAlt dc, bndrs, (CoreSyn.Var sel_bndr)) -> do
+ case List.elemIndex sel_bndr bndrs of
+ Just i -> do
+ labels <- MonadState.lift tsType $ getFieldLabels (Id.idType scrut)
+ let label = labels!!i
+ let sel_name = mkSelectedName (varToVHDLName scrut) label
+ let sel_expr = AST.PrimName sel_name
+ return ([mkUncondAssign (Left bndr) sel_expr], [])
+ Nothing -> error $ "\nVHDL.mkConcSM: Not in normal form: Not a selector case:\n" ++ (pprString expr)
+
+ _ -> error $ "\nVHDL.mkConcSM: Not in normal form: Not a selector case:\n" ++ (pprString expr)
+
+-- Multiple case alt are be conditional assignments and have only wild
+-- binders in the alts and only variables in the case values and a variable
+-- for a scrutinee. We check the constructor of the second alt, since the
+-- first is the default case, if there is any.
+mkConcSm (bndr, (CoreSyn.Case (CoreSyn.Var scrut) b ty [(_, _, CoreSyn.Var false), (con, _, CoreSyn.Var true)])) = do
+ scrut' <- MonadState.lift tsType $ varToVHDLExpr scrut
+ let cond_expr = scrut' AST.:=: (altconToVHDLExpr con)
+ true_expr <- MonadState.lift tsType $ varToVHDLExpr true
+ false_expr <- MonadState.lift tsType $ varToVHDLExpr false
+ return ([mkCondAssign (Left bndr) cond_expr true_expr false_expr], [])
+
+mkConcSm (_, (CoreSyn.Case (CoreSyn.Var _) _ _ alts)) = error "\nVHDL.mkConcSm: Not in normal form: Case statement with more than two alternatives"
+mkConcSm (_, CoreSyn.Case _ _ _ _) = error "\nVHDL.mkConcSm: Not in normal form: Case statement has does not have a simple variable as scrutinee"
+mkConcSm (bndr, expr) = error $ "\nVHDL.mkConcSM: Unsupported binding in let expression: " ++ pprString bndr ++ " = " ++ pprString expr
-----------------------------------------------------------------------------
-- Functions to generate VHDL for builtin functions
args' <- eitherCoreOrExprArgs args
wrap dst func args'
-eitherCoreOrExprArgs :: [Either CoreSyn.CoreExpr AST.Expr] -> VHDLSession [AST.Expr]
-eitherCoreOrExprArgs args = mapM (Either.either ((MonadState.lift vsType) . varToVHDLExpr . exprToVar) return) args
+eitherCoreOrExprArgs :: [Either CoreSyn.CoreExpr AST.Expr] -> TranslatorSession [AST.Expr]
+eitherCoreOrExprArgs args = mapM (Either.either ((MonadState.lift tsType) . varToVHDLExpr . exprToVar) return) args
+
+-- A function to wrap a builder-like function that generates no component
+-- instantiations
+genNoInsts ::
+ (dst -> func -> args -> TranslatorSession [AST.ConcSm])
+ -> (dst -> func -> args -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr]))
+genNoInsts wrap dst func args = do
+ concsms <- wrap dst func args
+ return (concsms, [])
-- | A function to wrap a builder-like function that expects its arguments to
-- be variables.
-- | A function to wrap a builder-like function that produces an expression
-- and expects it to be assigned to the destination.
genExprRes ::
- ((Either CoreSyn.CoreBndr AST.VHDLName) -> func -> [arg] -> VHDLSession AST.Expr)
- -> ((Either CoreSyn.CoreBndr AST.VHDLName) -> func -> [arg] -> VHDLSession [AST.ConcSm])
+ ((Either CoreSyn.CoreBndr AST.VHDLName) -> func -> [arg] -> TranslatorSession AST.Expr)
+ -> ((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]
-- | Generate a binary operator application. The first argument should be a
-- constructor from the AST.Expr type, e.g. AST.And.
genOperator2 :: (AST.Expr -> AST.Expr -> AST.Expr) -> BuiltinBuilder
-genOperator2 op = genExprArgs $ genExprRes (genOperator2' op)
-genOperator2' :: (AST.Expr -> AST.Expr -> AST.Expr) -> dst -> CoreSyn.CoreBndr -> [AST.Expr] -> VHDLSession AST.Expr
+genOperator2 op = genNoInsts $ genExprArgs $ genExprRes (genOperator2' op)
+genOperator2' :: (AST.Expr -> AST.Expr -> AST.Expr) -> dst -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession AST.Expr
genOperator2' op _ f [arg1, arg2] = return $ op arg1 arg2
-- | Generate a unary operator application
genOperator1 :: (AST.Expr -> AST.Expr) -> BuiltinBuilder
-genOperator1 op = genExprArgs $ genExprRes (genOperator1' op)
-genOperator1' :: (AST.Expr -> AST.Expr) -> dst -> CoreSyn.CoreBndr -> [AST.Expr] -> VHDLSession AST.Expr
+genOperator1 op = genNoInsts $ genExprArgs $ genExprRes (genOperator1' op)
+genOperator1' :: (AST.Expr -> AST.Expr) -> dst -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession AST.Expr
genOperator1' op _ f [arg] = return $ op arg
-- | Generate a unary operator application
genNegation :: BuiltinBuilder
-genNegation = genVarArgs $ genExprRes genNegation'
-genNegation' :: dst -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession AST.Expr
+genNegation = genNoInsts $ genVarArgs $ genExprRes genNegation'
+genNegation' :: dst -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession AST.Expr
genNegation' _ f [arg] = do
- arg1 <- MonadState.lift vsType $ varToVHDLExpr arg
+ arg1 <- MonadState.lift tsType $ varToVHDLExpr arg
let ty = Var.varType arg
let (tycon, args) = Type.splitTyConApp ty
let name = Name.getOccString (TyCon.tyConName tycon)
-- | Generate a function call from the destination binder, function name and a
-- list of expressions (its arguments)
genFCall :: Bool -> BuiltinBuilder
-genFCall switch = genExprArgs $ genExprRes (genFCall' switch)
-genFCall' :: Bool -> Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> VHDLSession AST.Expr
+genFCall switch = genNoInsts $ genExprArgs $ genExprRes (genFCall' switch)
+genFCall' :: Bool -> Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession AST.Expr
genFCall' switch (Left res) f args = do
let fname = varToString f
let el_ty = if switch then (Var.varType res) else ((tfvec_elem . Var.varType) res)
- id <- MonadState.lift vsType $ vectorFunId el_ty fname
+ id <- MonadState.lift tsType $ vectorFunId el_ty fname
return $ AST.PrimFCall $ AST.FCall (AST.NSimple id) $
map (\exp -> Nothing AST.:=>: AST.ADExpr exp) args
genFCall' _ (Right name) _ _ = error $ "\nGenerate.genFCall': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
genFromSizedWord :: BuiltinBuilder
-genFromSizedWord = genExprArgs $ genExprRes genFromSizedWord'
-genFromSizedWord' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> VHDLSession AST.Expr
+genFromSizedWord = genNoInsts $ genExprArgs $ genExprRes genFromSizedWord'
+genFromSizedWord' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession AST.Expr
genFromSizedWord' (Left res) f args = do
let fname = varToString f
return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId toIntegerId)) $
genFromSizedWord' (Right name) _ _ = error $ "\nGenerate.genFromSizedWord': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
genResize :: BuiltinBuilder
-genResize = genExprArgs $ genExprRes genResize'
-genResize' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> VHDLSession AST.Expr
+genResize = genNoInsts $ genExprArgs $ genExprRes genResize'
+genResize' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession AST.Expr
genResize' (Left res) f [arg] = do {
; let { ty = Var.varType res
; (tycon, args) = Type.splitTyConApp ty
; name = Name.getOccString (TyCon.tyConName tycon)
} ;
; len <- case name of
- "SizedInt" -> MonadState.lift vsType $ tfp_to_int (sized_int_len_ty ty)
- "SizedWord" -> MonadState.lift vsType $ tfp_to_int (sized_word_len_ty ty)
+ "SizedInt" -> MonadState.lift tsType $ tfp_to_int (sized_int_len_ty ty)
+ "SizedWord" -> MonadState.lift tsType $ tfp_to_int (sized_word_len_ty ty)
; return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId resizeId))
[Nothing AST.:=>: AST.ADExpr arg, Nothing AST.:=>: AST.ADExpr( AST.PrimLit (show len))]
}
-- FIXME: I'm calling genLitArgs which is very specific function,
-- which needs to be fixed as well
genFromInteger :: BuiltinBuilder
-genFromInteger = genLitArgs $ genExprRes genFromInteger'
-genFromInteger' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [Literal.Literal] -> VHDLSession AST.Expr
+genFromInteger = genNoInsts $ genLitArgs $ genExprRes genFromInteger'
+genFromInteger' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [Literal.Literal] -> TranslatorSession AST.Expr
genFromInteger' (Left res) f lits = do {
; let { ty = Var.varType res
; (tycon, args) = Type.splitTyConApp ty
"RangedWord" -> return $ AST.PrimLit (show (last lits))
otherwise -> do {
; len <- case name of
- "SizedInt" -> MonadState.lift vsType $ tfp_to_int (sized_int_len_ty ty)
- "SizedWord" -> MonadState.lift vsType $ tfp_to_int (sized_word_len_ty ty)
- "RangedWord" -> MonadState.lift vsType $ tfp_to_int (ranged_word_bound_ty ty)
+ "SizedInt" -> MonadState.lift tsType $ tfp_to_int (sized_int_len_ty ty)
+ "SizedWord" -> MonadState.lift tsType $ tfp_to_int (sized_word_len_ty ty)
+ "RangedWord" -> MonadState.lift tsType $ tfp_to_int (ranged_word_bound_ty ty)
; let fname = case name of "SizedInt" -> toSignedId ; "SizedWord" -> toUnsignedId
; return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId fname))
[Nothing AST.:=>: AST.ADExpr (AST.PrimLit (show (last lits))), Nothing AST.:=>: AST.ADExpr( AST.PrimLit (show len))]
genSizedInt :: BuiltinBuilder
genSizedInt = genFromInteger
+{-
-- | Generate a Builder for the builtin datacon TFVec
genTFVec :: BuiltinBuilder
genTFVec (Left res) f [Left (CoreSyn.Let (CoreSyn.Rec letBinders) letRes)] = do {
-- Get all the Assigned binders
; let assignedBinders = Maybe.catMaybes (map fst letAssigns)
-- Make signal names for all the assigned binders
- ; sigs <- mapM (\x -> MonadState.lift vsType $ varToVHDLExpr x) (assignedBinders ++ resBinders)
+ ; sigs <- mapM (\x -> MonadState.lift tsType $ varToVHDLExpr x) (assignedBinders ++ resBinders)
-- Assign all the signals to the resulting vector
; let { vecsigns = mkAggregateSignal sigs
; vecassign = mkUncondAssign (Left res) vecsigns
; return $ [AST.CSBSm block]
}
where
- genBinderAssign :: (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -> VHDLSession (Maybe CoreSyn.CoreBndr, [AST.ConcSm])
+ genBinderAssign :: (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -> TranslatorSession (Maybe CoreSyn.CoreBndr, [AST.ConcSm])
-- For now we only translate applications
genBinderAssign (bndr, app@(CoreSyn.App _ _)) = do
let (CoreSyn.Var f, args) = CoreSyn.collectArgs app
apps <- genApplication (Left bndr) f (map Left valargs)
return (Just bndr, apps)
genBinderAssign _ = return (Nothing,[])
- genResAssign :: CoreSyn.CoreExpr -> VHDLSession ([CoreSyn.CoreBndr], [AST.ConcSm])
+ genResAssign :: CoreSyn.CoreExpr -> TranslatorSession ([CoreSyn.CoreBndr], [AST.ConcSm])
genResAssign app@(CoreSyn.App _ letexpr) = do
case letexpr of
(CoreSyn.Let (CoreSyn.Rec letbndrs) letres) -> do
otherwise -> error $ "\nGenerate.genTFVec: Cannot generate TFVec: "
++ show res ++ ", with elems:\n" ++ show elems ++ "\n" ++ pprString elems) elems
} ;
- ; sigs <- mapM (\x -> MonadState.lift vsType $ varToVHDLExpr x) binders
+ ; sigs <- mapM (\x -> MonadState.lift tsType $ varToVHDLExpr x) binders
-- Assign all the signals to the resulting vector
; let { vecsigns = mkAggregateSignal sigs
; vecassign = mkUncondAssign (Left res) vecsigns
genTFVec (Left name) _ [Left xs] = error $ "\nGenerate.genTFVec: Cannot generate TFVec: " ++ show name ++ ", with elems:\n" ++ show xs ++ "\n" ++ pprString xs
genTFVec (Right name) _ _ = error $ "\nGenerate.genTFVec: Cannot generate TFVec assigned to VHDLName: " ++ show name
-
+-}
-- | Generate a generate statement for the builtin function "map"
genMap :: BuiltinBuilder
genMap (Left res) f [Left mapped_f, Left (CoreSyn.Var arg)] = do {
-- we must index it (which we couldn't if it was a VHDL Expr, since only
-- VHDLNames can be indexed).
-- Setup the generate scheme
- ; len <- MonadState.lift vsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) res
+ ; len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) res
-- TODO: Use something better than varToString
; let { label = mkVHDLExtId ("mapVector" ++ (varToString res))
; n_id = mkVHDLBasicId "n"
; (CoreSyn.Var real_f, already_mapped_args) = CoreSyn.collectArgs mapped_f
; valargs = get_val_args (Var.varType real_f) already_mapped_args
} ;
- ; app_concsms <- genApplication (Right resname) real_f (map Left valargs ++ [Right argexpr])
+ ; (app_concsms, used) <- genApplication (Right resname) real_f (map Left valargs ++ [Right argexpr])
-- Return the generate statement
- ; return [AST.CSGSm $ AST.GenerateSm label genScheme [] app_concsms]
+ ; return ([AST.CSGSm $ AST.GenerateSm label genScheme [] app_concsms], used)
}
genMap' (Right name) _ _ = error $ "\nGenerate.genMap': Cannot generate map function call assigned to a VHDLName: " ++ show name
genZipWith :: BuiltinBuilder
genZipWith = genVarArgs genZipWith'
-genZipWith' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm]
+genZipWith' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
genZipWith' (Left res) f args@[zipped_f, arg1, arg2] = do {
-- Setup the generate scheme
- ; len <- MonadState.lift vsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) res
+ ; len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) res
-- TODO: Use something better than varToString
; let { label = mkVHDLExtId ("zipWithVector" ++ (varToString res))
; n_id = mkVHDLBasicId "n"
; argexpr1 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg1) n_expr
; argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg2) n_expr
} ;
- ; app_concsms <- genApplication (Right resname) zipped_f [Right argexpr1, Right argexpr2]
+ ; (app_concsms, used) <- genApplication (Right resname) zipped_f [Right argexpr1, Right argexpr2]
-- Return the generate functions
- ; return [AST.CSGSm $ AST.GenerateSm label genScheme [] app_concsms]
+ ; return ([AST.CSGSm $ AST.GenerateSm label genScheme [] app_concsms], used)
}
genFoldl :: BuiltinBuilder
genFold :: Bool -> BuiltinBuilder
genFold left = genVarArgs (genFold' left)
-genFold' :: Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm]
+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 vsType $ 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] -> VHDLSession [AST.ConcSm]
+genFold'' :: Int -> Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
-- Special case for an empty input vector, just assign start to res
genFold'' len left (Left res) _ [_, start, vec] | len == 0 = do
- arg <- MonadState.lift vsType $ varToVHDLExpr start
- return [mkUncondAssign (Left res) arg]
+ arg <- MonadState.lift tsType $ varToVHDLExpr start
+ return ([mkUncondAssign (Left res) arg], [])
genFold'' len left (Left res) f [folded_f, start, vec] = do
-- The vector length
- --len <- MonadState.lift vsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) vec
+ --len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) vec
-- An expression for len-1
let len_min_expr = (AST.PrimLit $ show (len-1))
-- evec is (TFVec n), so it still needs an element type
-- temporary vector
let tmp_ty = Type.mkAppTy nvec (Var.varType start)
let error_msg = "\nGenerate.genFold': Can not construct temp vector for element type: " ++ pprString tmp_ty
- tmp_vhdl_ty <- MonadState.lift vsType $ vhdl_ty error_msg tmp_ty
+ tmp_vhdl_ty <- MonadState.lift tsType $ vhdl_ty error_msg tmp_ty
-- Setup the generate scheme
let gen_label = mkVHDLExtId ("foldlVector" ++ (varToString vec))
let block_label = mkVHDLExtId ("foldlVector" ++ (varToString res))
-- Make the intermediate vector
let tmp_dec = AST.BDISD $ AST.SigDec tmp_id tmp_vhdl_ty Nothing
-- Create the generate statement
- cells <- sequence [genFirstCell, genOtherCell]
+ cells' <- sequence [genFirstCell, genOtherCell]
+ let (cells, useds) = unzip cells'
let gen_sm = AST.GenerateSm gen_label gen_scheme [] (map AST.CSGSm cells)
-- Assign tmp[len-1] or tmp[0] to res
let out_assign = mkUncondAssign (Left res) $ vhdlNameToVHDLExpr (if left then
(mkIndexedName tmp_name (AST.PrimLit $ show (len-1))) else
(mkIndexedName tmp_name (AST.PrimLit "0")))
let block = AST.BlockSm block_label [] (AST.PMapAspect []) [tmp_dec] [AST.CSGSm gen_sm, out_assign]
- return [AST.CSBSm block]
+ return ([AST.CSBSm block], concat useds)
where
-- An id for the counter
n_id = mkVHDLBasicId "n"
tmp_id = mkVHDLBasicId "tmp"
tmp_name = AST.NSimple tmp_id
-- Generate parts of the fold
- genFirstCell, genOtherCell :: VHDLSession AST.GenerateSm
+ genFirstCell, genOtherCell :: TranslatorSession (AST.GenerateSm, [CoreSyn.CoreBndr])
genFirstCell = do
- len <- MonadState.lift vsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) vec
+ len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) vec
let cond_label = mkVHDLExtId "firstcell"
-- if n == 0 or n == len-1
let cond_scheme = AST.IfGn $ n_cur AST.:=: (if left then (AST.PrimLit "0")
-- Output to tmp[current n]
let resname = mkIndexedName tmp_name n_cur
-- Input from start
- argexpr1 <- MonadState.lift vsType $ varToVHDLExpr start
+ argexpr1 <- MonadState.lift tsType $ varToVHDLExpr start
-- Input from vec[current n]
let argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName vec) n_cur
- app_concsms <- genApplication (Right resname) folded_f ( if left then
+ (app_concsms, used) <- genApplication (Right resname) folded_f ( if left then
[Right argexpr1, Right argexpr2]
else
[Right argexpr2, Right argexpr1]
)
-- Return the conditional generate part
- return $ AST.GenerateSm cond_label cond_scheme [] app_concsms
+ return $ (AST.GenerateSm cond_label cond_scheme [] app_concsms, used)
genOtherCell = do
- len <- MonadState.lift vsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) vec
+ len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) vec
let cond_label = mkVHDLExtId "othercell"
-- if n > 0 or n < len-1
let cond_scheme = AST.IfGn $ n_cur AST.:/=: (if left then (AST.PrimLit "0")
let argexpr1 = vhdlNameToVHDLExpr $ mkIndexedName tmp_name n_prev
-- Input from vec[current n]
let argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName vec) n_cur
- app_concsms <- genApplication (Right resname) folded_f ( if left then
+ (app_concsms, used) <- genApplication (Right resname) folded_f ( if left then
[Right argexpr1, Right argexpr2]
else
[Right argexpr2, Right argexpr1]
)
-- Return the conditional generate part
- return $ AST.GenerateSm cond_label cond_scheme [] app_concsms
+ return $ (AST.GenerateSm cond_label cond_scheme [] app_concsms, used)
-- | Generate a generate statement for the builtin function "zip"
genZip :: BuiltinBuilder
-genZip = genVarArgs genZip'
-genZip' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm]
+genZip = genNoInsts $ genVarArgs genZip'
+genZip' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession [AST.ConcSm]
genZip' (Left res) f args@[arg1, arg2] = do {
-- Setup the generate scheme
- ; len <- MonadState.lift vsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) res
+ ; len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) res
-- TODO: Use something better than varToString
; let { label = mkVHDLExtId ("zipVector" ++ (varToString res))
; n_id = mkVHDLBasicId "n"
; argexpr1 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg1) n_expr
; argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg2) n_expr
} ;
- ; labels <- MonadState.lift vsType $ getFieldLabels (tfvec_elem (Var.varType res))
+ ; labels <- MonadState.lift tsType $ getFieldLabels (tfvec_elem (Var.varType res))
; let { resnameA = mkSelectedName resname' (labels!!0)
; resnameB = mkSelectedName resname' (labels!!1)
; resA_assign = mkUncondAssign (Right resnameA) argexpr1
-- | Generate a generate statement for the builtin function "unzip"
genUnzip :: BuiltinBuilder
-genUnzip = genVarArgs genUnzip'
-genUnzip' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm]
+genUnzip = genNoInsts $ genVarArgs genUnzip'
+genUnzip' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession [AST.ConcSm]
genUnzip' (Left res) f args@[arg] = do {
-- Setup the generate scheme
- ; len <- MonadState.lift vsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) arg
+ ; len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) arg
-- TODO: Use something better than varToString
; let { label = mkVHDLExtId ("unzipVector" ++ (varToString res))
; n_id = mkVHDLBasicId "n"
; resname' = varToVHDLName res
; argexpr' = mkIndexedName (varToVHDLName arg) n_expr
} ;
- ; reslabels <- MonadState.lift vsType $ getFieldLabels (Var.varType res)
- ; arglabels <- MonadState.lift vsType $ getFieldLabels (tfvec_elem (Var.varType arg))
+ ; reslabels <- MonadState.lift tsType $ getFieldLabels (Var.varType res)
+ ; arglabels <- MonadState.lift tsType $ getFieldLabels (tfvec_elem (Var.varType arg))
; let { resnameA = mkIndexedName (mkSelectedName resname' (reslabels!!0)) n_expr
; resnameB = mkIndexedName (mkSelectedName resname' (reslabels!!1)) n_expr
; argexprA = vhdlNameToVHDLExpr $ mkSelectedName argexpr' (arglabels!!0)
}
genCopy :: BuiltinBuilder
-genCopy = genVarArgs genCopy'
-genCopy' :: (Either CoreSyn.CoreBndr AST.VHDLName ) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm]
+genCopy = genNoInsts $ genVarArgs genCopy'
+genCopy' :: (Either CoreSyn.CoreBndr AST.VHDLName ) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession [AST.ConcSm]
genCopy' (Left res) f args@[arg] =
let
resExpr = AST.Aggregate [AST.ElemAssoc (Just AST.Others)
return [out_assign]
genConcat :: BuiltinBuilder
-genConcat = genVarArgs genConcat'
-genConcat' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm]
+genConcat = genNoInsts $ genVarArgs genConcat'
+genConcat' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession [AST.ConcSm]
genConcat' (Left res) f args@[arg] = do {
-- Setup the generate scheme
- ; len1 <- MonadState.lift vsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) arg
+ ; len1 <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) arg
; let (_, nvec) = Type.splitAppTy (Var.varType arg)
- ; len2 <- MonadState.lift vsType $ tfp_to_int $ tfvec_len_ty nvec
+ ; len2 <- MonadState.lift tsType $ tfp_to_int $ tfvec_len_ty nvec
-- TODO: Use something better than varToString
; let { label = mkVHDLExtId ("concatVector" ++ (varToString res))
; n_id = mkVHDLBasicId "n"
genIterateOrGenerate :: Bool -> BuiltinBuilder
genIterateOrGenerate iter = genVarArgs (genIterateOrGenerate' iter)
-genIterateOrGenerate' :: Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm]
+genIterateOrGenerate' :: Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
genIterateOrGenerate' iter (Left res) f args = do
- len <- MonadState.lift vsType $ tfp_to_int ((tfvec_len_ty . Var.varType) res)
+ len <- MonadState.lift tsType $ tfp_to_int ((tfvec_len_ty . Var.varType) res)
genIterateOrGenerate'' len iter (Left res) f args
-genIterateOrGenerate'' :: Int -> Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm]
+genIterateOrGenerate'' :: Int -> Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
-- Special case for an empty input vector, just assign start to res
-genIterateOrGenerate'' len iter (Left res) _ [app_f, start] | len == 0 = return [mkUncondAssign (Left res) (AST.PrimLit "\"\"")]
+genIterateOrGenerate'' len iter (Left res) _ [app_f, start] | len == 0 = return ([mkUncondAssign (Left res) (AST.PrimLit "\"\"")], [])
genIterateOrGenerate'' len iter (Left res) f [app_f, start] = do
-- The vector length
- -- len <- MonadState.lift vsType $ tfp_to_int ((tfvec_len_ty . Var.varType) res)
+ -- len <- MonadState.lift tsType $ tfp_to_int ((tfvec_len_ty . Var.varType) res)
-- An expression for len-1
let len_min_expr = (AST.PrimLit $ show (len-1))
-- -- evec is (TFVec n), so it still needs an element type
-- -- temporary vector
let tmp_ty = Var.varType res
let error_msg = "\nGenerate.genFold': Can not construct temp vector for element type: " ++ pprString tmp_ty
- tmp_vhdl_ty <- MonadState.lift vsType $ vhdl_ty error_msg tmp_ty
+ tmp_vhdl_ty <- MonadState.lift tsType $ vhdl_ty error_msg tmp_ty
-- Setup the generate scheme
let gen_label = mkVHDLExtId ("iterateVector" ++ (varToString start))
let block_label = mkVHDLExtId ("iterateVector" ++ (varToString res))
-- Make the intermediate vector
let tmp_dec = AST.BDISD $ AST.SigDec tmp_id tmp_vhdl_ty Nothing
-- Create the generate statement
- cells <- sequence [genFirstCell, genOtherCell]
+ cells' <- sequence [genFirstCell, genOtherCell]
+ let (cells, useds) = unzip cells'
let gen_sm = AST.GenerateSm gen_label gen_scheme [] (map AST.CSGSm cells)
-- Assign tmp[len-1] or tmp[0] to res
let out_assign = mkUncondAssign (Left res) $ vhdlNameToVHDLExpr tmp_name
let block = AST.BlockSm block_label [] (AST.PMapAspect []) [tmp_dec] [AST.CSGSm gen_sm, out_assign]
- return [AST.CSBSm block]
+ return ([AST.CSBSm block], concat useds)
where
-- An id for the counter
n_id = mkVHDLBasicId "n"
tmp_id = mkVHDLBasicId "tmp"
tmp_name = AST.NSimple tmp_id
-- Generate parts of the fold
- genFirstCell, genOtherCell :: VHDLSession AST.GenerateSm
+ genFirstCell, genOtherCell :: TranslatorSession (AST.GenerateSm, [CoreSyn.CoreBndr])
genFirstCell = do
let cond_label = mkVHDLExtId "firstcell"
-- if n == 0 or n == len-1
-- Output to tmp[current n]
let resname = mkIndexedName tmp_name n_cur
-- Input from start
- argexpr <- MonadState.lift vsType $ varToVHDLExpr start
+ argexpr <- MonadState.lift tsType $ varToVHDLExpr start
let startassign = mkUncondAssign (Right resname) argexpr
- app_concsms <- genApplication (Right resname) app_f [Right argexpr]
+ (app_concsms, used) <- genApplication (Right resname) app_f [Right argexpr]
-- Return the conditional generate part
- return $ AST.GenerateSm cond_label cond_scheme [] (if iter then
+ let gensm = AST.GenerateSm cond_label cond_scheme [] (if iter then
[startassign]
else
app_concsms
)
+ return (gensm, used)
genOtherCell = do
let cond_label = mkVHDLExtId "othercell"
let resname = mkIndexedName tmp_name n_cur
-- Input from tmp[previous n]
let argexpr = vhdlNameToVHDLExpr $ mkIndexedName tmp_name n_prev
- app_concsms <- genApplication (Right resname) app_f [Right argexpr]
+ (app_concsms, used) <- genApplication (Right resname) app_f [Right argexpr]
-- Return the conditional generate part
- return $ AST.GenerateSm cond_label cond_scheme [] app_concsms
+ return $ (AST.GenerateSm cond_label cond_scheme [] app_concsms, used)
-----------------------------------------------------------------------------
(Either CoreSyn.CoreBndr AST.VHDLName) -- ^ Where to store the result?
-> CoreSyn.CoreBndr -- ^ The function to apply
-> [Either CoreSyn.CoreExpr AST.Expr] -- ^ The arguments to apply
- -> VHDLSession [AST.ConcSm] -- ^ The resulting concurrent statements
+ -> 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
- signatures <- getA vsSignatures
- -- This is a local id, so it should be a function whose definition we
- -- have and which can be turned into a component instantiation.
- case (Map.lookup f signatures) of
- Just signature -> do
- args' <- eitherCoreOrExprArgs args
- -- We have a signature, this is a top level binding. Generate a
+ 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' <- eitherCoreOrExprArgs 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]
- Nothing -> do
- -- No signature, 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 vsType $ varToVHDLExpr f
- return $ [mkUncondAssign dst f']
+ 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
- labels <- MonadState.lift vsType $ getFieldLabels (Var.varType bndr)
+ labels <- MonadState.lift tsType $ getFieldLabels (Var.varType bndr)
args' <- eitherCoreOrExprArgs args
- return $ zipWith mkassign labels $ args'
+ return $ (zipWith mkassign labels $ args', [])
where
mkassign :: AST.VHDLId -> AST.Expr -> AST.ConcSm
mkassign label arg =
-- TODO: This should not be duplicated from mk_vector_ty. Probably but it in
-- the VHDLState or something.
let vectorTM = mkVHDLExtId $ "vector_" ++ (AST.fromVHDLId elemTM)
- typefuns <- getA vsTypeFuns
+ typefuns <- getA tsTypeFuns
case Map.lookup (OrdType el_ty, fname) typefuns of
-- Function already generated, just return it
Just (id, _) -> return id
let functions = genUnconsVectorFuns elemTM vectorTM
case lookup fname functions of
Just body -> do
- modA vsTypeFuns $ Map.insert (OrdType el_ty, fname) (function_id, (fst body))
+ modA tsTypeFuns $ Map.insert (OrdType el_ty, fname) (function_id, (fst body))
mapM_ (vectorFunId el_ty) (snd body)
return function_id
Nothing -> error $ "\nGenerate.vectorFunId: I don't know how to generate vector function " ++ fname
-- A table of builtin functions
-----------------------------------------------------------------------------
+-- A function that generates VHDL for a builtin function
+type BuiltinBuilder =
+ (Either CoreSyn.CoreBndr AST.VHDLName) -- ^ The destination signal and it's original type
+ -> CoreSyn.CoreBndr -- ^ The function called
+ -> [Either CoreSyn.CoreExpr AST.Expr] -- ^ The value arguments passed (excluding type and
+ -- dictionary arguments).
+ -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
+ -- ^ The corresponding VHDL concurrent statements and entities
+ -- instantiated.
+
+-- A map of a builtin function to VHDL function builder
+type NameTable = Map.Map String (Int, BuiltinBuilder )
+
-- | The builtin functions we support. Maps a name to an argument count and a
-- builder function.
globalNameTable :: NameTable
, (fromIntegerId , (1, genFromInteger ) )
, (resizeId , (1, genResize ) )
, (sizedIntId , (1, genSizedInt ) )
- , (tfvecId , (1, genTFVec ) )
+ --, (tfvecId , (1, genTFVec ) )
, (minimumId , (2, error $ "\nFunction name: \"minimum\" is used internally, use another name"))
]
--- /dev/null
+--
+-- Functions to create a VHDL testbench from a list of test input.
+--
+module CLasH.VHDL.Testbench where
+
+-- Standard modules
+import qualified Control.Monad as Monad
+import qualified Maybe
+import qualified Data.Map as Map
+import Data.Accessor
+import qualified Data.Accessor.MonadState as MonadState
+
+-- ForSyDe
+import qualified Language.VHDL.AST as AST
+
+-- GHC API
+import CoreSyn
+import qualified Var
+import qualified TysWiredIn
+
+-- Local imports
+import CLasH.Translator.TranslatorTypes
+import CLasH.VHDL.Constants
+import CLasH.VHDL.Generate
+import CLasH.VHDL.VHDLTools
+import CLasH.VHDL.VHDLTypes
+import CLasH.Normalize
+import CLasH.Utils.Core.BinderTools
+import CLasH.Utils.Core.CoreTools
+import CLasH.Utils
+
+createTestbench ::
+ Maybe Int -- ^ Number of cycles to simulate
+ -> CoreSyn.CoreExpr -- ^ Input stimuli
+ -> CoreSyn.CoreBndr -- ^ Top Entity
+ -> TranslatorSession CoreBndr -- ^ The id of the generated archictecture
+createTestbench mCycles stimuli top = do
+ let stimuli' = reduceCoreListToHsList stimuli
+ -- Create a binder for the testbench. We use the unit type (), since the
+ -- testbench has no outputs and no inputs.
+ bndr <- mkInternalVar "testbench" TysWiredIn.unitTy
+ let entity = createTestbenchEntity bndr
+ modA tsEntities (Map.insert bndr entity)
+ arch <- createTestbenchArch mCycles stimuli' top entity
+ modA tsArchitectures (Map.insert bndr arch)
+ return bndr
+
+createTestbenchEntity ::
+ CoreSyn.CoreBndr
+ -> Entity
+createTestbenchEntity bndr = entity
+ where
+ vhdl_id = mkVHDLBasicId $ varToString bndr
+ -- Create an AST entity declaration with no ports
+ ent_decl = AST.EntityDec vhdl_id []
+ -- Create a signature with no input and no output ports
+ entity = Entity vhdl_id [] undefined ent_decl
+
+createTestbenchArch ::
+ Maybe Int -- ^ Number of cycles to simulate
+ -> [CoreSyn.CoreExpr] -- ^ Imput stimuli
+ -> CoreSyn.CoreBndr -- ^ Top Entity
+ -> Entity -- ^ The signature to create an architecture for
+ -> TranslatorSession (Architecture, [CoreSyn.CoreBndr])
+ -- ^ The architecture and any other entities used.
+createTestbenchArch mCycles stimuli top testent= do
+ signature <- getEntity top
+ let entId = ent_id signature
+ iIface = ent_args signature
+ oIface = ent_res signature
+ iIds = map fst iIface
+ oId = fst oIface
+ let iDecs = map (\(vId, tm) -> AST.SigDec vId tm Nothing) iIface
+ let finalIDecs = iDecs ++
+ [AST.SigDec clockId std_logicTM (Just $ AST.PrimLit "'0'"),
+ AST.SigDec resetId std_logicTM (Just $ AST.PrimLit "'0'")]
+ let oDecs = AST.SigDec (fst oIface) (snd oIface) Nothing
+ let portmaps = mkAssocElems (map idToVHDLExpr iIds) (AST.NSimple oId) signature
+ let mIns = mkComponentInst "totest" entId portmaps
+ (stimuliAssigns, stimuliDecs, cycles, used) <- createStimuliAssigns mCycles stimuli (head iIds)
+ let finalAssigns = (AST.CSSASm (AST.NSimple resetId AST.:<==:
+ AST.ConWforms []
+ (AST.Wform [AST.WformElem (AST.PrimLit "'1'") (Just $ AST.PrimLit "3 ns")])
+ Nothing)) : stimuliAssigns
+ let clkProc = createClkProc
+ let outputProc = createOutputProc [oId]
+ let arch = AST.ArchBody
+ (AST.unsafeVHDLBasicId "test")
+ (AST.NSimple $ ent_id testent)
+ (map AST.BDISD (finalIDecs ++ stimuliDecs ++ [oDecs]))
+ (mIns :
+ ( (AST.CSPSm clkProc) : (AST.CSPSm outputProc) : finalAssigns ) )
+ return (arch, top : used)
+
+createStimuliAssigns ::
+ Maybe Int -- ^ Number of cycles to simulate
+ -> [CoreSyn.CoreExpr] -- ^ Input stimuli
+ -> AST.VHDLId -- ^ Input signal
+ -> TranslatorSession ( [AST.ConcSm] -- ^ Resulting statemetns
+ , [AST.SigDec] -- ^ Needed signals
+ , Int -- ^ The number of cycles to simulate
+ , [CoreSyn.CoreBndr]) -- ^ Any entities used
+createStimuliAssigns mCycles [] _ = return ([], [], Maybe.maybe 0 id mCycles, [])
+
+createStimuliAssigns mCycles stimuli signal = do
+ let genWformElem time stim = (AST.WformElem stim (Just $ AST.PrimLit (show time ++ " ns")))
+ let inputlen = length stimuli
+ assigns <- Monad.zipWithM createStimulans stimuli [0..inputlen]
+ let (stimuli_sms, resvars, useds) = unzip3 assigns
+ sig_dec_maybes <- mapM mkSigDec resvars
+ let sig_decs = Maybe.catMaybes sig_dec_maybes
+ outps <- mapM (\x -> MonadState.lift tsType (varToVHDLExpr x)) resvars
+ let wformelems = zipWith genWformElem [0,10..] outps
+ let inassign = AST.CSSASm $ AST.NSimple signal AST.:<==: AST.ConWforms [] (AST.Wform wformelems) Nothing
+ return (stimuli_sms ++ [inassign], sig_decs, inputlen, concat useds)
+
+createStimulans ::
+ CoreSyn.CoreExpr -- ^ The stimulans
+ -> Int -- ^ The cycle for this stimulans
+ -> TranslatorSession ( AST.ConcSm -- ^ The statement
+ , Var.Var -- ^ the variable it assigns to (assumed to be available!)
+ , [CoreSyn.CoreBndr]) -- ^ Any entities used by this stimulans
+
+createStimulans expr cycl = do
+ -- There must be a let at top level
+ (CoreSyn.Let (CoreSyn.Rec binds) (Var res)) <- normalizeExpr ("test input #" ++ show cycl) 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 block_label = mkVHDLExtId ("testcycle_" ++ (show cycl))
+ let block = AST.BlockSm block_label [] (AST.PMapAspect []) sig_decs (concat stimulansbindss)
+ return (AST.CSBSm block, res, concat useds)
+
+-- | generates a clock process with a period of 10ns
+createClkProc :: AST.ProcSm
+createClkProc = AST.ProcSm (AST.unsafeVHDLBasicId "clkproc") [] sms
+ where sms = -- wait for 5 ns -- (half a cycle)
+ [AST.WaitFor $ AST.PrimLit "5 ns",
+ -- clk <= not clk;
+ AST.NSimple clockId `AST.SigAssign`
+ AST.Wform [AST.WformElem (AST.Not (AST.PrimName $ AST.NSimple clockId)) Nothing]]
+
+-- | generate the output process
+createOutputProc :: [AST.VHDLId] -- ^ output signal
+ -> AST.ProcSm
+createOutputProc outs =
+ AST.ProcSm (AST.unsafeVHDLBasicId "writeoutput")
+ [clockId]
+ [AST.IfSm clkPred (writeOuts outs) [] Nothing]
+ where clkPred = AST.PrimName (AST.NAttribute $ AST.AttribName (AST.NSimple clockId)
+ (AST.NSimple $ eventId)
+ Nothing ) `AST.And`
+ (AST.PrimName (AST.NSimple clockId) AST.:=: AST.PrimLit "'1'")
+ writeOuts :: [AST.VHDLId] -> [AST.SeqSm]
+ writeOuts [] = []
+ writeOuts [i] = [writeOut i (AST.PrimLit "LF")]
+ writeOuts (i:is) = writeOut i (AST.PrimLit "HT") : writeOuts is
+ writeOut outSig suffix =
+ genExprPCall2 writeId
+ (AST.PrimName $ AST.NSimple outputId)
+ ((genExprFCall showId (AST.PrimName $ AST.NSimple outSig)) AST.:&: suffix)
-- Local imports
import CLasH.VHDL.VHDLTypes
+import CLasH.Translator.TranslatorTypes
import CLasH.Utils.Core.CoreTools
import CLasH.Utils.Pretty
import CLasH.VHDL.Constants
-- Returns either an error message or the resulting type.
vhdl_ty_either :: Type.Type -> TypeSession (Either String AST.TypeMark)
vhdl_ty_either ty = do
- typemap <- getA vsTypes
+ typemap <- getA tsTypes
htype_either <- mkHType ty
case htype_either of
-- No errors
case newty_maybe of
Right (ty_id, ty_def) -> do
-- TODO: Check name uniqueness
- modA vsTypes (Map.insert htype (ty_id, ty_def))
- modA vsTypeDecls (\typedefs -> typedefs ++ [mktydecl (ty_id, ty_def)])
+ modA tsTypes (Map.insert htype (ty_id, ty_def))
+ modA tsTypeDecls (\typedefs -> typedefs ++ [mktydecl (ty_id, ty_def)])
return (Right ty_id)
Left err -> return $ Left $
"VHDLTools.vhdl_ty: Unsupported Haskell type: " ++ pprString ty ++ "\n"
let ty_id = mkVHDLExtId $ nameToString (TyCon.tyConName tycon) ++ elem_names
let ty_def = AST.TDR $ AST.RecordTypeDef elems
let tupshow = mkTupleShow elem_tys ty_id
- modA vsTypeFuns $ Map.insert (OrdType ty, showIdString) (showId, tupshow)
+ modA tsTypeFuns $ Map.insert (OrdType ty, showIdString) (showId, tupshow)
return $ Right (ty_id, Left ty_def)
-- There were errors in element types
(errors, _) -> return $ Left $
-- ^ An error message or The typemark created.
mk_vector_ty ty = do
- types_map <- getA vsTypes
- env <- getA vsHscEnv
+ types_map <- getA tsTypes
+ env <- getA tsHscEnv
let (nvec_l, nvec_el) = Type.splitAppTy ty
let (nvec, leng) = Type.splitAppTy nvec_l
let vec_ty = Type.mkAppTy nvec nvec_el
Nothing -> do
let vec_id = mkVHDLExtId $ "vector_" ++ (AST.fromVHDLId el_ty_tm)
let vec_def = AST.TDA $ AST.UnconsArrayDef [tfvec_indexTM] el_ty_tm
- modA vsTypes (Map.insert (StdType $ OrdType vec_ty) (vec_id, (Left vec_def)))
- modA vsTypeDecls (\typedefs -> typedefs ++ [mktydecl (vec_id, (Left vec_def))])
+ modA tsTypes (Map.insert (StdType $ OrdType vec_ty) (vec_id, (Left vec_def)))
+ modA tsTypeDecls (\typedefs -> typedefs ++ [mktydecl (vec_id, (Left vec_def))])
let vecShowFuns = mkVectorShow el_ty_tm vec_id
- mapM_ (\(id, subprog) -> modA vsTypeFuns $ Map.insert (OrdType vec_ty, id) ((mkVHDLExtId id), subprog)) vecShowFuns
+ mapM_ (\(id, subprog) -> modA tsTypeFuns $ Map.insert (OrdType vec_ty, id) ((mkVHDLExtId id), subprog)) vecShowFuns
let ty_def = AST.SubtypeIn vec_id (Just range)
return (Right (ty_id, Right ty_def))
-- Could not create element type
let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (size - 1))]
let ty_def = AST.SubtypeIn unsignedTM (Just range)
let unsignedshow = mkIntegerShow ty_id
- modA vsTypeFuns $ Map.insert (OrdType ty, showIdString) (showId, unsignedshow)
+ modA tsTypeFuns $ Map.insert (OrdType ty, showIdString) (showId, unsignedshow)
return (Right (ty_id, Right ty_def))
mk_signed_ty ::
let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (size - 1))]
let ty_def = AST.SubtypeIn signedTM (Just range)
let signedshow = mkIntegerShow ty_id
- modA vsTypeFuns $ Map.insert (OrdType ty, showIdString) (showId, signedshow)
+ modA tsTypeFuns $ Map.insert (OrdType ty, showIdString) (showId, signedshow)
return (Right (ty_id, Right ty_def))
-- Finds the field labels for VHDL type generated for the given Core type,
let error_msg = "\nVHDLTools.getFieldLabels: Can not get field labels, because: " ++ pprString ty ++ "can not be generated."
vhdl_ty error_msg ty
-- Get the types map, lookup and unpack the VHDL TypeDef
- types <- getA vsTypes
+ types <- getA tsTypes
-- Assume the type for which we want labels is really translatable
Right htype <- mkHType ty
case Map.lookup htype types of
tfp_to_int :: Type.Type -> TypeSession Int
tfp_to_int ty = do
- hscenv <- getA vsHscEnv
+ hscenv <- getA tsHscEnv
let norm_ty = normalise_tfp_int hscenv ty
case Type.splitTyConApp_maybe norm_ty of
Just (tycon, args) -> do
len <- tfp_to_int' ty
return len
otherwise -> do
- modA vsTfpInts (Map.insert (OrdType norm_ty) (-1))
+ modA tsTfpInts (Map.insert (OrdType norm_ty) (-1))
return $ error ("Callin tfp_to_int on non-dec:" ++ (show ty))
Nothing -> return $ error ("Callin tfp_to_int on non-dec:" ++ (show ty))
tfp_to_int' :: Type.Type -> TypeSession Int
tfp_to_int' ty = do
- lens <- getA vsTfpInts
- hscenv <- getA vsHscEnv
+ lens <- getA tsTfpInts
+ hscenv <- getA tsHscEnv
let norm_ty = normalise_tfp_int hscenv ty
let existing_len = Map.lookup (OrdType norm_ty) lens
case existing_len of
Just len -> return len
Nothing -> do
let new_len = eval_tfp_int hscenv ty
- modA vsTfpInts (Map.insert (OrdType norm_ty) (new_len))
+ modA tsTfpInts (Map.insert (OrdType norm_ty) (new_len))
return new_len
mkTupleShow ::
AST.ProcCall (AST.NSimple entid) $
map (\exp -> Nothing AST.:=>: AST.ADExpr exp) [arg1,arg2]
-mkSigDec :: CoreSyn.CoreBndr -> VHDLSession (Maybe AST.SigDec)
+mkSigDec :: CoreSyn.CoreBndr -> TranslatorSession (Maybe AST.SigDec)
mkSigDec bndr =
if True then do --isInternalSigUse use || isStateSigUse use then do
let error_msg = "\nVHDL.mkSigDec: Can not make signal declaration for type: \n" ++ pprString bndr
- type_mark <- MonadState.lift vsType $ vhdl_ty error_msg (Var.varType bndr)
+ type_mark <- MonadState.lift tsType $ vhdl_ty error_msg (Var.varType bndr)
return $ Just (AST.SigDec (varToVHDLId bndr) type_mark Nothing)
else
return Nothing
import qualified Data.Accessor.Template
-- GHC API imports
-import qualified Type
-import qualified CoreSyn
import qualified HscTypes
-- ForSyDe imports
data Entity = Entity {
ent_id :: AST.VHDLId, -- The id of the entity
ent_args :: [Port], -- A mapping of each function argument to port names
- ent_res :: Port -- A mapping of the function result to port names
+ ent_res :: Port, -- A mapping of the function result to port names
+ ent_dec :: AST.EntityDec -- ^ The complete entity declaration
} deriving (Show);
--- A orderable equivalent of CoreSyn's Type for use as a map key
-newtype OrdType = OrdType { getType :: Type.Type }
-instance Eq OrdType where
- (OrdType a) == (OrdType b) = Type.tcEqType a b
-instance Ord OrdType where
- compare (OrdType a) (OrdType b) = Type.tcCmpType a b
-
-data HType = StdType OrdType |
- ADTType String [HType] |
- VecType Int HType |
- SizedWType Int |
- RangedWType Int |
- SizedIType Int |
- BuiltinType String
- deriving (Eq, Ord)
-
--- A map of a Core type to the corresponding type name
-type TypeMap = Map.Map HType (AST.VHDLId, Either AST.TypeDef AST.SubtypeIn)
-
--- A map of a vector Core element type and function name to the coressponding
--- VHDLId of the function and the function body.
-type TypeFunMap = Map.Map (OrdType, String) (AST.VHDLId, AST.SubProgBody)
-
--- A map of a Haskell function to a hardware signature
-type SignatureMap = Map.Map CoreSyn.CoreBndr Entity
-
-type TfpIntMap = Map.Map OrdType Int
-
-data TypeState = TypeState {
- -- | A map of Core type -> VHDL Type
- vsTypes_ :: TypeMap,
- -- | A list of type declarations
- vsTypeDecls_ :: [AST.PackageDecItem],
- -- | A map of vector Core type -> VHDL type function
- vsTypeFuns_ :: TypeFunMap,
- vsTfpInts_ :: TfpIntMap,
- vsHscEnv_ :: HscTypes.HscEnv
-}
--- Derive accessors
-$( Data.Accessor.Template.deriveAccessors ''TypeState )
--- Define a session
-type TypeSession = State.State TypeState
-
-data VHDLState = VHDLState {
- -- | A subtype with typing info
- vsType_ :: TypeState,
- -- | A map of HsFunction -> hardware signature (entity name, port names,
- -- etc.)
- vsSignatures_ :: SignatureMap
-}
-
--- Derive accessors
-$( Data.Accessor.Template.deriveAccessors ''VHDLState )
-
--- | The state containing a VHDL Session
-type VHDLSession = State.State VHDLState
-
--- A function that generates VHDL for a builtin function
-type BuiltinBuilder =
- (Either CoreSyn.CoreBndr AST.VHDLName) -- ^ The destination signal and it's original type
- -> CoreSyn.CoreBndr -- ^ The function called
- -> [Either CoreSyn.CoreExpr AST.Expr] -- ^ The value arguments passed (excluding type and
- -- dictionary arguments).
- -> VHDLSession [AST.ConcSm] -- ^ The resulting concurrent statements.
-
--- A map of a builtin function to VHDL function builder
-type NameTable = Map.Map String (Int, BuiltinBuilder )
+type Architecture = AST.ArchBody
-- vim: set ts=8 sw=2 sts=2 expandtab:
projects / matthijs / master-project / cλash.git / commitdiff