-- top level function "normalize", and defines the actual transformation passes that
-- are performed.
--
-module CLasH.Normalize (normalizeModule) where
+module CLasH.Normalize (getNormalized) 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.Pretty
-- 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
+-- | Returns the normalized version of the given function.
+getNormalized ::
+ CoreBndr -- ^ The function to get
+ -> TranslatorSession CoreExpr -- The normalized function body
-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)
+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
+ -- 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 ()
+ return expr''
-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!"
+-- | 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
-- 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
-- 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
-- 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
-- over a single expression and track if the expression was changed.
type TransformMonad = Writer.WriterT Monoid.Any TransformSession
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.Core.CoreTools
import CLasH.Utils.GhcTools
-> [Maybe CoreSyn.CoreExpr] -- ^ The TestInput
-> 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 topbinds' init test stateful = do
+ let topbinds = Maybe.catMaybes topbinds'
+ let initialState = Maybe.catMaybes init
+ let testInput = Maybe.catMaybes test
+ 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
+ --let testexprs = case testInput of [] -> [] ; [x] -> reduceCoreListToHsList x
+ createDesignFiles topbinds
+ mapM (putStr . render . Ppr.ppr . snd) vhdl
+ return vhdl
+
+-- 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 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 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 )
+
+-- Compatibility with old VHDLSession
+vsTypes = tsTypes
+vsTypeDecls = tsTypeDecls
+vsTypeFuns = tsTypeFuns
+vsTfpInts = tsTfpInts
+vsHscEnv = tsHscEnv
+
+-- 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
+
+-- Compatibility for the old VHDLSesssion
+vsType = tsType
+type VHDLSession = TranslatorSession
+
+-- Compatibility for the old TransformSession
+type TransformSession = TranslatorSession
-type TranslatorState = State.State TranslatorSession
+-- 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
-- vim: set ts=8 sw=2 sts=2 expandtab:
module CLasH.Utils
( listBindings
, listBind
+ , makeCached
) where
-- Standard Imports
import qualified Maybe
+import Data.Accessor
+import qualified Data.Map as Map
+import qualified Control.Monad.Trans.State as State
-- GHC API
import qualified CoreSyn
listBinding (Maybe.fromJust $ head corebind, Maybe.fromJust $ head coreexpr)
where
bindFinder = findBind (hasVarName name)
- exprFinder = findExpr (hasVarName name)
\ No newline at end of file
+ exprFinder = findExpr (hasVarName name)
+
+-- 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
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.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])]
-
-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
+createLibraryUnit ::
+ CoreSyn.CoreBndr
+ -> TranslatorSession (AST.VHDLId, [AST.LibraryUnit])
--- | 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
(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
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
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
+ -> VHDLSession 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 AST.EntityDec entity_id _ = ent_decl'
+ let signature = Entity entity_id args' res' ent_decl'
+ return signature
+ 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
+
+-- | Create an architecture for a given function
+getArchitecture ::
+ CoreSyn.CoreBndr -- ^ The function to get an architecture for
+ -> VHDLSession (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 vsTypes 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 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, (CoreSyn.Case (CoreSyn.Var scrut) b ty [(_, _, CoreSyn.Var false), (con, _, CoreSyn.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 (_, (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
eitherCoreOrExprArgs :: [Either CoreSyn.CoreExpr AST.Expr] -> VHDLSession [AST.Expr]
eitherCoreOrExprArgs args = mapM (Either.either ((MonadState.lift vsType) . 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.
genVarArgs ::
-- | 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 op = genNoInsts $ genExprArgs $ genExprRes (genOperator2' op)
genOperator2' :: (AST.Expr -> AST.Expr -> AST.Expr) -> dst -> CoreSyn.CoreBndr -> [AST.Expr] -> VHDLSession 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 op = genNoInsts $ genExprArgs $ genExprRes (genOperator1' op)
genOperator1' :: (AST.Expr -> AST.Expr) -> dst -> CoreSyn.CoreBndr -> [AST.Expr] -> VHDLSession AST.Expr
genOperator1' op _ f [arg] = return $ op arg
-- | Generate a unary operator application
genNegation :: BuiltinBuilder
-genNegation = genVarArgs $ genExprRes genNegation'
+genNegation = genNoInsts $ genVarArgs $ genExprRes genNegation'
genNegation' :: dst -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession AST.Expr
genNegation' _ f [arg] = do
arg1 <- MonadState.lift vsType $ varToVHDLExpr arg
-- | 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 switch = genNoInsts $ genExprArgs $ genExprRes (genFCall' switch)
genFCall' :: Bool -> Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> VHDLSession AST.Expr
genFCall' switch (Left res) f args = do
let fname = varToString f
genFCall' _ (Right name) _ _ = error $ "\nGenerate.genFCall': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
genFromSizedWord :: BuiltinBuilder
-genFromSizedWord = genExprArgs $ genExprRes genFromSizedWord'
+genFromSizedWord = genNoInsts $ genExprArgs $ genExprRes genFromSizedWord'
genFromSizedWord' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> VHDLSession AST.Expr
genFromSizedWord' (Left res) f args = do
let fname = varToString f
genFromSizedWord' (Right name) _ _ = error $ "\nGenerate.genFromSizedWord': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
genResize :: BuiltinBuilder
-genResize = genExprArgs $ genExprRes genResize'
+genResize = genNoInsts $ genExprArgs $ genExprRes genResize'
genResize' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> VHDLSession AST.Expr
genResize' (Left res) f [arg] = do {
; let { ty = Var.varType res
-- FIXME: I'm calling genLitArgs which is very specific function,
-- which needs to be fixed as well
genFromInteger :: BuiltinBuilder
-genFromInteger = genLitArgs $ genExprRes genFromInteger'
+genFromInteger = genNoInsts $ genLitArgs $ genExprRes genFromInteger'
genFromInteger' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [Literal.Literal] -> VHDLSession AST.Expr
genFromInteger' (Left res) f lits = do {
; let { ty = Var.varType res
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 {
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 {
; (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] -> VHDLSession ([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
; 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] -> VHDLSession ([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))
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] -> VHDLSession ([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]
+ return ([mkUncondAssign (Left res) arg], [])
genFold'' len left (Left res) f [folded_f, start, vec] = do
-- The vector length
-- 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 :: VHDLSession (AST.GenerateSm, [CoreSyn.CoreBndr])
genFirstCell = do
len <- MonadState.lift vsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) vec
let cond_label = mkVHDLExtId "firstcell"
argexpr1 <- MonadState.lift vsType $ 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
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 = genNoInsts $ genVarArgs genZip'
genZip' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm]
genZip' (Left res) f args@[arg1, arg2] = do {
-- Setup the generate scheme
-- | Generate a generate statement for the builtin function "unzip"
genUnzip :: BuiltinBuilder
-genUnzip = genVarArgs genUnzip'
+genUnzip = genNoInsts $ genVarArgs genUnzip'
genUnzip' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm]
genUnzip' (Left res) f args@[arg] = do {
-- Setup the generate scheme
}
genCopy :: BuiltinBuilder
-genCopy = genVarArgs genCopy'
+genCopy = genNoInsts $ genVarArgs genCopy'
genCopy' :: (Either CoreSyn.CoreBndr AST.VHDLName ) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm]
genCopy' (Left res) f args@[arg] =
let
return [out_assign]
genConcat :: BuiltinBuilder
-genConcat = genVarArgs genConcat'
+genConcat = genNoInsts $ genVarArgs genConcat'
genConcat' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm]
genConcat' (Left res) f args@[arg] = do {
-- Setup the generate scheme
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] -> VHDLSession ([AST.ConcSm], [CoreSyn.CoreBndr])
genIterateOrGenerate' iter (Left res) f args = do
len <- MonadState.lift vsType $ 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] -> VHDLSession ([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
-- 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 :: VHDLSession (AST.GenerateSm, [CoreSyn.CoreBndr])
genFirstCell = do
let cond_label = mkVHDLExtId "firstcell"
-- if n == 0 or n == len-1
-- Input from start
argexpr <- MonadState.lift vsType $ 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.
+ 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 vsType $ varToVHDLExpr f
- return $ [mkUncondAssign dst f']
+ return $ ([mkUncondAssign dst f'], [])
True ->
case Var.idDetails f of
IdInfo.DataConWorkId dc -> case dst of
-- We have the bndr, so we can get at the type
labels <- MonadState.lift vsType $ 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 =
-- 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 ) )
]
-- Local imports
import CLasH.VHDL.VHDLTypes
+import CLasH.Translator.TranslatorTypes
import CLasH.Utils.Core.CoreTools
import CLasH.Utils.Pretty
import CLasH.VHDL.Constants
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