-- | Generate a binary operator application. The first argument should be a
-- constructor from the AST.Expr type, e.g. AST.And.
-genExprOp2 :: (AST.Expr -> AST.Expr -> AST.Expr) -> [AST.Expr] -> AST.Expr
-genExprOp2 op [arg1, arg2] = op arg1 arg2
+genExprOp2 :: (AST.Expr -> AST.Expr -> AST.Expr) -> [AST.Expr] -> VHDLSession AST.Expr
+genExprOp2 op [arg1, arg2] = return $ op arg1 arg2
-- | Generate a unary operator application
-genExprOp1 :: (AST.Expr -> AST.Expr) -> [AST.Expr] -> AST.Expr
-genExprOp1 op [arg] = op arg
+genExprOp1 :: (AST.Expr -> AST.Expr) -> [AST.Expr] -> VHDLSession AST.Expr
+genExprOp1 op [arg] = return $ op arg
-- | Generate a function call from the Function Name and a list of expressions
-- (its arguments)
-genExprFCall :: AST.VHDLId -> [AST.Expr] -> AST.Expr
+genExprFCall :: AST.VHDLId -> [AST.Expr] -> VHDLSession AST.Expr
genExprFCall fName args =
- AST.PrimFCall $ AST.FCall (AST.NSimple fName) $
+ return $ AST.PrimFCall $ AST.FCall (AST.NSimple fName) $
map (\exp -> Nothing AST.:=>: AST.ADExpr exp) args
-- | Generate a generate statement for the builtin function "map"
genMapCall ::
Entity -- | The entity to map
-> [CoreSyn.CoreBndr] -- | The vectors
- -> AST.GenerateSm -- | The resulting generate statement
-genMapCall entity [arg, res] = genSm
+ -> VHDLSession AST.GenerateSm -- | The resulting generate statement
+genMapCall entity [arg, res] = return $ genSm
where
-- Setup the generate scheme
len = (tfvec_len . Var.varType) res
map (Arrow.second $ AST.DesignFile full_context) units
where
- init_session = VHDLSession Map.empty Map.empty Map.empty Map.empty globalNameTable
+ init_session = VHDLState Map.empty Map.empty Map.empty Map.empty
(units, final_session) =
State.runState (createLibraryUnits binds) init_session
tyfun_decls = Map.elems (final_session ^.vsTypeFuns)
createLibraryUnits ::
[(CoreSyn.CoreBndr, CoreSyn.CoreExpr)]
- -> VHDLState [(AST.VHDLId, [AST.LibraryUnit])]
+ -> VHDLSession [(AST.VHDLId, [AST.LibraryUnit])]
createLibraryUnits binds = do
entities <- Monad.mapM createEntity binds
-- | Create an entity for a given function
createEntity ::
(CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- | The function
- -> VHDLState AST.EntityDec -- | The resulting entity
+ -> VHDLSession AST.EntityDec -- | The resulting entity
createEntity (fname, expr) = do
-- Strip off lambda's, these will be arguments
mkMap ::
--[(SignalId, SignalInfo)]
CoreSyn.CoreBndr
- -> VHDLState VHDLSignalMapElement
+ -> VHDLSession VHDLSignalMapElement
-- We only need the vsTypes element from the state
mkMap = (\bndr ->
let
-- | Create an architecture for a given function
createArchitecture ::
(CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The function
- -> VHDLState AST.ArchBody -- ^ The architecture for this function
+ -> VHDLSession AST.ArchBody -- ^ The architecture for this function
createArchitecture (fname, expr) = do
signaturemap <- getA vsSignatures
(sigName info)
-}
-mkSigDec :: CoreSyn.CoreBndr -> VHDLState (Maybe AST.SigDec)
+mkSigDec :: CoreSyn.CoreBndr -> VHDLSession (Maybe AST.SigDec)
mkSigDec bndr =
if True then do --isInternalSigUse use || isStateSigUse use then do
type_mark <- vhdl_ty $ Var.varType bndr
-- | Transforms a core binding into a VHDL concurrent statement
mkConcSm ::
(CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The binding to process
- -> VHDLState [AST.ConcSm] -- ^ The corresponding VHDL component instantiations.
+ -> VHDLSession [AST.ConcSm] -- ^ The corresponding VHDL component instantiations.
-- Ignore Cast expressions, they should not longer have any meaning as long as
IdInfo.VanillaGlobal -> do
-- It's a global value imported from elsewhere. These can be builtin
-- functions.
- funSignatures <- getA vsNameTable
signatures <- getA vsSignatures
- case (Map.lookup (varToString f) funSignatures) of
+ case (Map.lookup (varToString f) globalNameTable) of
Just (arg_count, builder) ->
if length valargs == arg_count then
case builder of
- Left funBuilder ->
- let
- sigs = map (varToVHDLExpr.exprToVar) valargs
- func = funBuilder sigs
- src_wform = AST.Wform [AST.WformElem func Nothing]
- dst_name = AST.NSimple (mkVHDLExtId (varToString bndr))
- assign = dst_name AST.:<==: (AST.ConWforms [] src_wform Nothing)
- in
- return [AST.CSSASm assign]
- Right genBuilder ->
- let
- sigs = map exprToVar valargs
- signature = Maybe.fromMaybe
- (error $ "Using function '" ++ (varToString (head sigs)) ++ "' without signature? This should not happen!")
- (Map.lookup (head sigs) signatures)
- arg = tail sigs
- genSm = genBuilder signature (arg ++ [bndr])
- in return [AST.CSGSm genSm]
+ Left funBuilder -> do
+ let sigs = map (varToVHDLExpr.exprToVar) valargs
+ func <- funBuilder sigs
+ let src_wform = AST.Wform [AST.WformElem func Nothing]
+ let dst_name = AST.NSimple (mkVHDLExtId (varToString bndr))
+ let assign = dst_name AST.:<==: (AST.ConWforms [] src_wform Nothing)
+ return [AST.CSSASm assign]
+ Right genBuilder -> do
+ let sigs = map exprToVar valargs
+ let signature = Maybe.fromMaybe
+ (error $ "Using function '" ++ (varToString (head sigs)) ++ "' without signature? This should not happen!")
+ (Map.lookup (head sigs) signatures)
+ let arg = tail sigs
+ genSm <- genBuilder signature (arg ++ [bndr])
+ return [AST.CSGSm genSm]
else
error $ "VHDL.mkConcSm Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ pprString valargs
Nothing -> error $ "Using function from another module that is not a known builtin: " ++ pprString f
]
-- Translate a Haskell type to a VHDL type, generating a new type if needed.
-vhdl_ty :: Type.Type -> VHDLState AST.TypeMark
+vhdl_ty :: Type.Type -> VHDLSession AST.TypeMark
vhdl_ty ty = do
typemap <- getA vsTypes
let builtin_ty = do -- See if this is a tycon and lookup its name
Nothing -> error $ "Unsupported Haskell type: " ++ pprString ty
-- Construct a new VHDL type for the given Haskell type.
-construct_vhdl_ty :: Type.Type -> VHDLState (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
+construct_vhdl_ty :: Type.Type -> VHDLSession (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
construct_vhdl_ty ty = do
case Type.splitTyConApp_maybe ty of
Just (tycon, args) -> do
Nothing -> return $ Nothing
-- | Create VHDL type for a custom tycon
-mk_tycon_ty :: TyCon.TyCon -> [Type.Type] -> VHDLState (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
+mk_tycon_ty :: TyCon.TyCon -> [Type.Type] -> VHDLSession (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
mk_tycon_ty tycon args =
case TyCon.tyConDataCons tycon of
-- Not an algebraic type
mk_vector_ty ::
Int -- ^ The length of the vector
-> Type.Type -- ^ The Haskell element type of the Vector
- -> VHDLState (AST.TypeMark, AST.SubtypeIn) -- The typemark created.
+ -> VHDLSession (AST.TypeMark, AST.SubtypeIn) -- The typemark created.
mk_vector_ty len el_ty = do
elem_types_map <- getA vsElemTypes
mk_natural_ty ::
Int -- ^ The minimum bound (> 0)
-> Int -- ^ The maximum bound (> minimum bound)
- -> VHDLState (AST.TypeMark, AST.SubtypeIn) -- The typemark created.
+ -> VHDLSession (AST.TypeMark, AST.SubtypeIn) -- The typemark created.
mk_natural_ty min_bound max_bound = do
let ty_id = mkVHDLExtId $ "nat_" ++ (show min_bound) ++ "_to_" ++ (show max_bound)
let range = AST.ConstraintRange $ AST.SubTypeRange (AST.PrimLit $ (show min_bound)) (AST.PrimLit $ (show max_bound))
-- Finds the field labels for VHDL type generated for the given Core type,
-- which must result in a record type.
-getFieldLabels :: Type.Type -> VHDLState [AST.VHDLId]
+getFieldLabels :: Type.Type -> VHDLSession [AST.VHDLId]
getFieldLabels ty = do
-- Ensure that the type is generated (but throw away it's VHDLId)
vhdl_ty ty
-- A map of a Haskell function to a hardware signature
type SignatureMap = Map.Map CoreSyn.CoreBndr Entity
-type Builder = Either ([AST.Expr] -> AST.Expr) (Entity -> [CoreSyn.CoreBndr] -> AST.GenerateSm)
-
--- A map of a builtin function to VHDL function builder
-type NameTable = Map.Map String (Int, Builder )
-
-data VHDLSession = VHDLSession {
+data VHDLState = VHDLState {
-- | A map of Core type -> VHDL Type
vsTypes_ :: TypeMap,
-- | A map of Elem types -> VHDL Vector Id
vsTypeFuns_ :: TypeFunMap,
-- | A map of HsFunction -> hardware signature (entity name, port names,
-- etc.)
- vsSignatures_ :: SignatureMap,
- -- | A map of Vector HsFunctions -> VHDL function call
- vsNameTable_ :: NameTable
+ vsSignatures_ :: SignatureMap
}
-- Derive accessors
-$( Data.Accessor.Template.deriveAccessors ''VHDLSession )
+$( Data.Accessor.Template.deriveAccessors ''VHDLState )
-- | The state containing a VHDL Session
-type VHDLState = State.State VHDLSession
+type VHDLSession = State.State VHDLState
-- | A substate containing just the types
type TypeState = State.State TypeMap
+type Builder = Either ([AST.Expr] -> VHDLSession AST.Expr) (Entity -> [CoreSyn.CoreBndr] -> VHDLSession AST.GenerateSm)
+
+-- A map of a builtin function to VHDL function builder
+type NameTable = Map.Map String (Int, Builder )
+
-- vim: set ts=8 sw=2 sts=2 expandtab: