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)
+
+-}
projects / matthijs / master-project / cλash.git / blobdiff