clash-0.1.3.9: CLasH/VHDL/Generate.hs
module CLasH.VHDL.Generate where
-- Standard modules
import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Control.Monad as Monad
import qualified Maybe
import qualified Data.Either as Either
import qualified Data.Accessor.Monad.Trans.StrictState as MonadState
-- VHDL Imports
import qualified Language.VHDL.AST as AST
-- GHC API
import qualified CoreSyn
import qualified Type
import qualified Var
import qualified Id
import qualified IdInfo
import qualified Literal
import qualified Name
import qualified TyCon
import qualified CoreUtils
-- Local imports
import CLasH.Translator.TranslatorTypes
import CLasH.VHDL.Constants
import CLasH.VHDL.VHDLTypes
import CLasH.VHDL.VHDLTools
import CLasH.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 = makeCached fname tsEntities $ do
expr <- Normalize.getNormalized False fname
-- Split the normalized expression
let (args, binds, res) = Normalize.splitNormalized expr
-- Generate ports for all non-empty types
args' <- catMaybesM $ mapM mkMap args
-- TODO: Handle Nothing
res' <- mkMap res
count <- MonadState.get tsEntityCounter
let vhdl_id = mkVHDLBasicId $ varToString fname ++ "Component_" ++ show count
MonadState.set tsEntityCounter (count + 1)
clocks <- MonadState.get tsClocks
let clockList = (Set.toList . Set.fromList . Map.elems) clocks
let ent_decl = createEntityAST vhdl_id clockList args' res'
let signature = Entity vhdl_id args' res' ent_decl
return signature
where
mkMap ::
--[(SignalId, SignalInfo)]
CoreSyn.CoreBndr
-> TranslatorSession (Maybe 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_maybe <- MonadState.lift tsType $ vhdlTy error_msg ty
case type_mark_maybe of
Just type_mark -> return $ Just (id, type_mark)
Nothing -> return Nothing
)
-- | Create the VHDL AST for an entity
createEntityAST ::
AST.VHDLId -- ^ The name of the function
-> [(Bool,Integer)] -- ^ Clocks
-> [Port] -- ^ The entity's arguments
-> Maybe Port -- ^ The entity's result
-> AST.EntityDec -- ^ The entity with the ent_decl filled in as well
createEntityAST vhdl_id clocks 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
++ (Maybe.maybeToList res_port)
++ clkPorts
++ [resetn_port]
-- TODO: Only add a clk ports if we have state
clkPorts = map ((\a -> AST.IfaceSigDec a AST.In std_logicTM) . AST.unsafeVHDLBasicId . ("clock" ++) . show . snd)
(if (null clocks) then [(undefined,1)] else clocks)
resetn_port = AST.IfaceSigDec resetId AST.In std_logicTM
res_port = fmap (mkIfaceSigDec AST.Out) res
-- | Create a port declaration
mkIfaceSigDec ::
AST.Mode -- ^ The mode for the port (In / Out)
-> Port -- ^ 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 = makeCached fname tsArchitectures $ do
expr <- Normalize.getNormalized False fname
-- Split the normalized expression
let (args, binds, res) = Normalize.splitNormalized expr
-- Get the entity for this function
signature <- getEntity fname
let entity_id = ent_id signature
-- 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
-- Process each bind, resulting in info about state variables and concurrent
-- statements.
(state_vars, sms) <- Monad.mapAndUnzipM dobind binds
let (in_state_maybes, out_state_maybes) = unzip state_vars
let (statementss, used_entitiess) = unzip sms
-- Get initial state, if it's there
initSmap <- MonadState.get tsInitStates
let init_state = Map.lookup fname initSmap
-- Get clock domains, if they're there
clocksMap <- MonadState.get tsClocks
let clockEdge = Map.lookup fname clocksMap
-- Create a state proc, if needed
(state_proc, resbndr) <- case (Maybe.catMaybes in_state_maybes, Maybe.catMaybes out_state_maybes, init_state) of
([in_state], [out_state], Nothing) -> do
nonEmpty <- hasNonEmptyType "\n Generate.getArchitecture (in_state)" in_state
if nonEmpty
then error ("Generate.getArchitecture: No initial state defined for: " ++ show fname)
else return ([],[])
([in_state], [out_state], Just resetval) -> do
nonEmpty <- hasNonEmptyType "" in_state
if nonEmpty
then mkStateProcSm (in_state, out_state, resetval, Maybe.fromMaybe (error $ "Generate.getArchitecture: No clock found for: " ++ show fname ++ ", listed clocks: " ++ show clocksMap) clockEdge)
else do
nonEmptyReset <- hasNonEmptyType "" resetval
if nonEmptyReset
then error ("Generate.getArchitecture: Initial state defined for function with only substate: " ++ show fname)
else return ([],[])
([], [], Just _) -> error $ "Initial state defined for state-less function: " ++ show fname
([], [], Nothing) -> return ([],[])
(ins, outs, res) -> error $ "Weird use of state in " ++ show fname ++ ". In: " ++ show ins ++ " Out: " ++ show outs
-- Join the create statements and the (optional) state_proc
let statements = concat statementss ++ state_proc
-- Create the architecture
let arch = AST.ArchBody (mkVHDLBasicId "structural") (AST.NSimple entity_id) (map AST.BDISD sig_decs) statements
let used_entities = (concat used_entitiess) ++ resbndr
return (arch, used_entities)
where
dobind :: (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The bind to process
-> TranslatorSession ((Maybe CoreSyn.CoreBndr, Maybe CoreSyn.CoreBndr), ([AST.ConcSm], [CoreSyn.CoreBndr]))
-- ^ ((Input state variable, output state variable), (statements, used entities))
-- newtype unpacking is just a cast
dobind (bndr, unpacked@(CoreSyn.Cast packed coercion))
| hasStateType packed && not (hasStateType unpacked)
= return ((Just bndr, Nothing), ([], []))
-- With simplCore, newtype packing is just a cast
dobind (bndr, packed@(CoreSyn.Cast unpacked@(CoreSyn.Var state) coercion))
| hasStateType packed && not (hasStateType unpacked)
= return ((Nothing, Just state), ([], []))
-- Without simplCore, newtype packing uses a data constructor
dobind (bndr, (CoreSyn.App (CoreSyn.App (CoreSyn.Var con) (CoreSyn.Type _)) (CoreSyn.Var state)))
| isStateCon con
= return ((Nothing, Just state), ([], []))
-- Anything else is handled by mkConcSm
dobind bind = do
sms <- mkConcSm bind
return ((Nothing, Nothing), sms)
mkStateProcSm ::
(CoreSyn.CoreBndr, CoreSyn.CoreBndr, CoreSyn.CoreBndr, (Bool, Integer)) -- ^ The current state, new state, reset variables, and clock domain
-> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr]) -- ^ The resulting statements
mkStateProcSm (old, new, res, (edge, period)) = do
let error_msg = "\nVHDL.mkSigDec: Can not make signal declaration for type: \n" ++ pprString res
type_mark_old_maybe <- MonadState.lift tsType $ vhdlTy error_msg (Var.varType old)
let type_mark_old = Maybe.fromMaybe
(error $ "\nGenerate.mkStateProcSm: empty type for state? Type: " ++ pprString (Var.varType old))
type_mark_old_maybe
type_mark_res_maybe <- MonadState.lift tsType $ vhdlTy error_msg (Var.varType res)
let type_mark_res' = Maybe.fromMaybe
(error $ "\nGenerate.mkStateProcSm: empty type for initial state? Type: " ++ pprString (Var.varType res))
type_mark_res_maybe
let type_mark_res = if type_mark_old == type_mark_res' then
type_mark_res'
else
error $ "Initial state has different type than state type, state type: " ++ show type_mark_old ++ ", init type: " ++ show type_mark_res'
let resvalid = mkVHDLExtId $ varToString res ++ "val"
let resvaldec = AST.BDISD $ AST.SigDec resvalid type_mark_res Nothing
let reswform = AST.Wform [AST.WformElem (AST.PrimName $ AST.NSimple resvalid) Nothing]
let res_assign = AST.SigAssign (varToVHDLName old) reswform
let blocklabel = mkVHDLBasicId "state"
let statelabel = mkVHDLBasicId "stateupdate"
let rising_edge = AST.NSimple $ mkVHDLBasicId "rising_edge"
let falling_edge = AST.NSimple $ mkVHDLBasicId "falling_edge"
let wform = AST.Wform [AST.WformElem (AST.PrimName $ varToVHDLName new) Nothing]
let clk_assign = AST.SigAssign (varToVHDLName old) wform
let clockId = AST.unsafeVHDLBasicId ("clock" ++ show period)
let clkFlank = AST.PrimFCall $ AST.FCall (if edge then rising_edge else falling_edge) [Nothing AST.:=>: (AST.ADName $ AST.NSimple clockId)]
let resetn_is_low = (AST.PrimName $ AST.NSimple resetId) AST.:=: (AST.PrimLit "'0'")
signature <- getEntity res
let entity_id = ent_id signature
let reslabel = "resetval_" ++ ((prettyShow . varToVHDLName) res)
let portmaps = mkAssocElems [] (AST.NSimple resvalid) signature
clocksMap <- MonadState.get tsClocks
let clockDomains = ((map snd) . Set.toList . Set.fromList . Map.elems) clocksMap
let reset_statement = mkComponentInst reslabel entity_id clockDomains portmaps
let clk_statement = [AST.ElseIf clkFlank [clk_assign]]
let statement = AST.IfSm resetn_is_low [res_assign] clk_statement Nothing
let stateupdate = AST.CSPSm $ AST.ProcSm statelabel [clockId,resetId,resvalid] [statement]
let block = AST.CSBSm $ AST.BlockSm blocklabel [] (AST.PMapAspect []) [resvaldec] [reset_statement,stateupdate]
return ([block],[res])
-- | 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. Throw away state repacking
mkConcSm (bndr, to@(CoreSyn.Cast from ty))
| hasStateType to && hasStateType from
= return ([],[])
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, Var.varType 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, Var.varType bndr) f (zip (map Left valargs) (map CoreUtils.exprType valargs))
-- A single alt case must be a selector. This means the 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]))
-- Don't generate VHDL for substate extraction
| hasStateType bndr = return ([], [])
| otherwise =
case alt of
(CoreSyn.DataAlt dc, bndrs, (CoreSyn.Var sel_bndr)) -> do
nonemptysel <- hasNonEmptyType "\n Generate.mkConcSm (nonemptysel)" sel_bndr
if nonemptysel
then do
bndrs' <- Monad.filterM (hasNonEmptyType ("\n Generate.mkConcSm (bndr'): " ++ show bndrs)) bndrs
case List.elemIndex sel_bndr bndrs' of
Just sel_i -> do
htypeScrt <- MonadState.lift tsType $ mkHTypeEither (Var.varType scrut)
htypeBndr <- MonadState.lift tsType $ mkHTypeEither (Var.varType bndr)
case htypeScrt == htypeBndr of
True -> do
let sel_name = varToVHDLName scrut
let sel_expr = AST.PrimName sel_name
return ([mkUncondAssign (Left bndr) sel_expr], [])
otherwise ->
case htypeScrt of
Right htype@(AggrType _ _ _) -> do
let dc_i = datacon_index (Id.idType scrut) dc
let labels = getFieldLabels htype dc_i
let label = labels!!sel_i
let sel_name = mkSelectedName (varToVHDLName scrut) label
let sel_expr = AST.PrimName sel_name
return ([mkUncondAssign (Left bndr) sel_expr], [])
_ -> do -- error $ "DIE!"
let sel_name = varToVHDLName scrut
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: result is not one of the binders\n" ++ (pprString expr)
else
-- A selector case that selects a state value, ignore it.
return ([], [])
_ -> error $ "\nVHDL.mkConcSM: Not in normal form: Not a selector case:\n" ++ (pprString expr)
-- Multiple case alt become 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, expr@(CoreSyn.Case (CoreSyn.Var scrut) _ _ alts)) = do
htype <- MonadState.lift tsType $ mkHType ("\nVHDL.mkConcSm: Unrepresentable scrutinee type? Expression: " ++ pprString expr) scrut
-- Turn the scrutinee into a VHDLExpr
scrut_expr <- MonadState.lift tsType $ varToVHDLExpr scrut
(enums, cmp) <- case htype of
EnumType _ enums -> do
-- Enumeration type, compare with the scrutinee directly
return (map (AST.PrimLit . show) [0..(length enums)-1], scrut_expr)
AggrType _ (Just (name, EnumType _ enums)) _ -> do
-- Extract the enumeration field from the aggregation
let sel_name = mkSelectedName (varToVHDLName scrut) (mkVHDLBasicId name)
let sel_expr = AST.PrimName sel_name
return (map (AST.PrimLit . show) [0..(length enums)-1], sel_expr)
(BuiltinType "Bit") -> do
let enums = [AST.PrimLit "'1'", AST.PrimLit "'0'"]
return (enums, scrut_expr)
(BuiltinType "Bool") -> do
let enums = [AST.PrimLit "false", AST.PrimLit "true"]
return (enums, scrut_expr)
_ -> error $ "\nSelector case on weird scrutinee: " ++ pprString scrut ++ " scrutinee type: " ++ pprString (Id.idType scrut)
-- Omit first condition, which is the default. Look up each altcon in
-- the enums list from the HType to find the actual enum value names.
let altcons = map (\(CoreSyn.DataAlt dc, _, _) -> enums!!(datacon_index scrut dc)) (tail alts)
-- Compare the (constructor field of the) scrutinee with each of the
-- alternatives.
let cond_exprs = map (\x -> cmp AST.:=: x) altcons
-- Rotate expressions to the left, so that the expression related to the default case is the last
exprs <- MonadState.lift tsType $ mapM (varToVHDLExpr . (\(_,_,CoreSyn.Var expr) -> expr)) ((tail alts) ++ [head alts])
return ([mkAltsAssign (Left bndr) cond_exprs exprs], [])
mkConcSm (_, expr@(CoreSyn.Case _ _ _ _)) = error $ "\nVHDL.mkConcSm: Not in normal form: Case statement does not have a simple variable as scrutinee; expr:\n" ++ pprString expr
mkConcSm (bndr, expr) = error $ "\nVHDL.mkConcSM: Unsupported binding in let expression: " ++ pprString bndr ++ " = " ++ pprString expr
-----------------------------------------------------------------------------
-- Functions to generate VHDL for builtin functions
-----------------------------------------------------------------------------
-- | A function to wrap a builder-like function that expects its arguments to
-- be expressions.
genExprArgs wrap dst func args = do
args' <- argsToVHDLExprs (map fst args)
wrap dst func (zip args' (map snd args))
-- | Turn the all lefts into VHDL Expressions.
argsToVHDLExprs :: [Either CoreSyn.CoreExpr AST.Expr] -> TranslatorSession [AST.Expr]
argsToVHDLExprs = catMaybesM . (mapM argToVHDLExpr)
argToVHDLExpr :: Either CoreSyn.CoreExpr AST.Expr -> TranslatorSession (Maybe AST.Expr)
argToVHDLExpr (Left expr) = MonadState.lift tsType $ do
let errmsg = "Generate.argToVHDLExpr: Using non-representable type? Should not happen! Expr: \n" ++ show expr ++ "\n has Type:\n" ++ show (CoreUtils.exprType expr) ++ "\n"
ty_maybe <- vhdlTy errmsg expr
case ty_maybe of
Just _ -> do
vhdl_expr <- varToVHDLExpr $ exprToVar expr
return $ Just vhdl_expr
Nothing -> return Nothing
argToVHDLExpr (Right expr) = return $ Just expr
-- 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 ::
-- (dst -> func -> [Var.Var] -> res)
-- -> (dst -> func -> [Either CoreSyn.CoreExpr AST.Expr] -> res)
-- genVarArgs wrap = genCoreArgs $ \dst func args -> let
-- args' = map exprToVar args
-- in
-- wrap dst func args'
-- | A function to wrap a builder-like function that expects its arguments to
-- be core expressions.
genCoreArgs ::
(dst -> func -> [CoreSyn.CoreExpr] -> res)
-> (dst -> func -> [(Either CoreSyn.CoreExpr AST.Expr, Type.Type)] -> res)
genCoreArgs wrap dst func args = wrap dst func args'
where
-- Check (rather crudely) that all arguments are CoreExprs
args' = case Either.partitionEithers (map fst args) of
(exprargs, []) -> exprargs
(exprsargs, rest) -> error $ "\nGenerate.genCoreArgs: expect core expression arguments but found ast exprs:" ++ (show rest)
-- | 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] -> 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 = genNoInsts $ genExprArgs $ genExprRes (genOperator2' op)
genOperator2' :: (AST.Expr -> AST.Expr -> AST.Expr) -> dst -> CoreSyn.CoreBndr -> [(AST.Expr, Type.Type)] -> 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 = genNoInsts $ genExprArgs $ genExprRes (genOperator1' op)
genOperator1' :: (AST.Expr -> AST.Expr) -> dst -> CoreSyn.CoreBndr -> [(AST.Expr, Type.Type)] -> TranslatorSession AST.Expr
genOperator1' op _ f [(arg,_)] = return $ op arg
-- | Generate a unary operator application
genNegation :: BuiltinBuilder
genNegation = genNoInsts $ genExprRes genNegation'
genNegation' :: dst -> CoreSyn.CoreBndr -> [(Either CoreSyn.CoreExpr AST.Expr, Type.Type)] -> TranslatorSession AST.Expr
genNegation' _ f [(arg,argType)] = do
[arg1] <- argsToVHDLExprs [arg]
let (tycon, args) = Type.splitTyConApp argType
let name = Name.getOccString (TyCon.tyConName tycon)
case name of
"Signed" -> return $ AST.Neg arg1
otherwise -> error $ "\nGenerate.genNegation': Negation not allowed for type: " ++ show name
-- | Generate a function call from the destination binder, function name and a
-- list of expressions (its arguments)
genFCall :: Bool -> BuiltinBuilder
genFCall switch = genNoInsts $ genExprArgs $ genExprRes (genFCall' switch)
genFCall' :: Bool -> Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [(AST.Expr, Type.Type)] -> 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 tsType $ vectorFunId el_ty fname
return $ AST.PrimFCall $ AST.FCall (AST.NSimple id) $
map (\exp -> Nothing AST.:=>: AST.ADExpr exp) (map fst args)
genFCall' _ (Right name) _ _ = error $ "\nGenerate.genFCall': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
genFromSizedWord :: BuiltinBuilder
genFromSizedWord = genNoInsts $ genExprArgs genFromSizedWord'
genFromSizedWord' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [(AST.Expr, Type.Type)] -> TranslatorSession [AST.ConcSm]
genFromSizedWord' (Left res) f args@[(arg,_)] =
return [mkUncondAssign (Left res) arg]
-- let fname = varToString f
-- return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId toIntegerId)) $
-- map (\exp -> Nothing AST.:=>: AST.ADExpr exp) args
genFromSizedWord' (Right name) _ _ = error $ "\nGenerate.genFromSizedWord': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
genFromRangedWord :: BuiltinBuilder
genFromRangedWord = genNoInsts $ genExprArgs $ genExprRes genFromRangedWord'
genFromRangedWord' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [(AST.Expr, Type.Type)] -> TranslatorSession AST.Expr
genFromRangedWord' (Left res) f [(arg,_)] = do {
; let { ty = Var.varType res
; (tycon, args) = Type.splitTyConApp ty
; name = Name.getOccString (TyCon.tyConName tycon)
} ;
; len <- 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))]
}
genFromRangedWord' (Right name) _ _ = error $ "\nGenerate.genFromRangedWord': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
genResize :: BuiltinBuilder
genResize = genNoInsts $ genExprArgs $ genExprRes genResize'
genResize' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [(AST.Expr, Type.Type)] -> 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
"Signed" -> MonadState.lift tsType $ tfp_to_int (sized_int_len_ty ty)
"Unsigned" -> 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))]
}
genResize' (Right name) _ _ = error $ "\nGenerate.genFromSizedWord': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
genTimes :: BuiltinBuilder
genTimes = genNoInsts $ genExprArgs $ genExprRes genTimes'
genTimes' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [(AST.Expr, Type.Type)] -> TranslatorSession AST.Expr
genTimes' (Left res) f [(arg1,_),(arg2,_)] = do {
; let { ty = Var.varType res
; (tycon, args) = Type.splitTyConApp ty
; name = Name.getOccString (TyCon.tyConName tycon)
} ;
; len <- case name of
"Signed" -> MonadState.lift tsType $ tfp_to_int (sized_int_len_ty ty)
"Unsigned" -> MonadState.lift tsType $ tfp_to_int (sized_word_len_ty ty)
"Index" -> do { ubound <- MonadState.lift tsType $ tfp_to_int (ranged_word_bound_ty ty)
; let bitsize = ceiling (logBase 2 (fromInteger (toInteger ubound)))
; return bitsize
}
; return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId resizeId))
[Nothing AST.:=>: AST.ADExpr (arg1 AST.:*: arg2), Nothing AST.:=>: AST.ADExpr( AST.PrimLit (show len))]
}
genTimes' (Right name) _ _ = error $ "\nGenerate.genTimes': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
-- fromInteger turns an Integer into a Num instance. Since Integer is
-- not representable and is only allowed for literals, the actual
-- Integer should be inlined entirely into the fromInteger argument.
genFromInteger :: BuiltinBuilder
genFromInteger = genNoInsts $ genCoreArgs $ genExprRes genFromInteger'
genFromInteger' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [CoreSyn.CoreExpr] -> TranslatorSession AST.Expr
genFromInteger' (Left res) f args = do
let ty = Var.varType res
let (tycon, tyargs) = Type.splitTyConApp ty
let name = Name.getOccString (TyCon.tyConName tycon)
len <- case name of
"Signed" -> MonadState.lift tsType $ tfp_to_int (sized_int_len_ty ty)
"Unsigned" -> MonadState.lift tsType $ tfp_to_int (sized_word_len_ty ty)
"Index" -> do
bound <- MonadState.lift tsType $ tfp_to_int (ranged_word_bound_ty ty)
return $ (ceiling (logBase 2 (fromInteger (toInteger (bound)))))
let fname = case name of "Signed" -> toSignedId ; "Unsigned" -> toUnsignedId ; "Index" -> toUnsignedId
case args of
[integer] -> do -- The type and dictionary arguments are removed by genApplication
literal <- getIntegerLiteral integer
return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId fname))
[Nothing AST.:=>: AST.ADExpr (AST.PrimLit (show literal)), Nothing AST.:=>: AST.ADExpr( AST.PrimLit (show len))]
_ -> error $ "\nGenerate.genFromInteger': Wrong number of arguments to genInteger. Applying " ++ pprString f ++ " to " ++ pprString args
genFromInteger' (Right name) _ _ = error $ "\nGenerate.genFromInteger': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
genSizedInt :: BuiltinBuilder
genSizedInt = genFromInteger
{-
-- This function is useful for use with vectorTH, since that generates
-- explicit references to the TFVec constructor (which is normally
-- hidden). Below implementation is probably not current anymore, but
-- kept here in case we start using vectorTH again.
-- | Generate a Builder for the builtin datacon TFVec
genTFVec :: BuiltinBuilder
genTFVec (Left res) f [Left (CoreSyn.Let (CoreSyn.Rec letBinders) letRes)] = do {
-- Generate Assignments for all the binders
; letAssigns <- mapM genBinderAssign letBinders
-- Generate assignments for the result (which might be another let binding)
; (resBinders,resAssignments) <- genResAssign letRes
-- 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 tsType $ varToVHDLExpr x) (assignedBinders ++ resBinders)
-- Assign all the signals to the resulting vector
; let { vecsigns = mkAggregateSignal sigs
; vecassign = mkUncondAssign (Left res) vecsigns
} ;
-- Generate all the signal declaration for the assigned binders
; sig_dec_maybes <- mapM mkSigDec (assignedBinders ++ resBinders)
; let { sig_decs = map (AST.BDISD) (Maybe.catMaybes $ sig_dec_maybes)
-- Setup the VHDL Block
; block_label = mkVHDLExtId ("TFVec_" ++ show (varToString res))
; block = AST.BlockSm block_label [] (AST.PMapAspect []) sig_decs ((concat (map snd letAssigns)) ++ resAssignments ++ [vecassign])
} ;
-- Return the block statement coressponding to the TFVec literal
; return $ [AST.CSBSm block]
}
where
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
let valargs = get_val_args (Var.varType f) args
apps <- genApplication (Left bndr) f (map Left valargs)
return (Just bndr, apps)
genBinderAssign _ = return (Nothing,[])
genResAssign :: CoreSyn.CoreExpr -> TranslatorSession ([CoreSyn.CoreBndr], [AST.ConcSm])
genResAssign app@(CoreSyn.App _ letexpr) = do
case letexpr of
(CoreSyn.Let (CoreSyn.Rec letbndrs) letres) -> do
letapps <- mapM genBinderAssign letbndrs
let bndrs = Maybe.catMaybes (map fst letapps)
let app = (map snd letapps)
(vars, apps) <- genResAssign letres
return ((bndrs ++ vars),((concat app) ++ apps))
otherwise -> return ([],[])
genResAssign _ = return ([],[])
genTFVec (Left res) f [Left app@(CoreSyn.App _ _)] = do {
; let { elems = reduceCoreListToHsList app
-- Make signal names for all the binders
; binders = map (\expr -> case expr of
(CoreSyn.Var b) -> b
otherwise -> error $ "\nGenerate.genTFVec: Cannot generate TFVec: "
++ show res ++ ", with elems:\n" ++ show elems ++ "\n" ++ pprString elems) elems
} ;
; 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
-- Setup the VHDL Block
; block_label = mkVHDLExtId ("TFVec_" ++ show (varToString res))
; block = AST.BlockSm block_label [] (AST.PMapAspect []) [] [vecassign]
} ;
-- Return the block statement coressponding to the TFVec literal
; return $ [AST.CSBSm block]
}
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 {
-- mapped_f must be a CoreExpr (since we can't represent functions as VHDL
-- expressions). arg must be a CoreExpr (and should be a CoreSyn.Var), since
-- 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 tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) res
; let res_type = (tfvec_elem . Var.varType) res
-- TODO: Use something better than varToString
; let { label = mkVHDLExtId ("mapVector" ++ (varToUniqString res))
; n_id = mkVHDLBasicId "n"
; n_expr = idToVHDLExpr n_id
; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
; genScheme = AST.ForGn n_id range
-- Create the content of the generate statement: Applying the mapped_f to
-- each of the elements in arg, storing to each element in res
; resname = mkIndexedName (varToVHDLName res) n_expr
; argexpr = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg) n_expr
; (CoreSyn.Var real_f, already_mapped_args) = CoreSyn.collectArgs mapped_f
; valargs = get_val_args (Var.varType real_f) already_mapped_args
} ;
; (app_concsms, used) <- genApplication (Right resname,res_type) real_f ((zip (map Left valargs) (map CoreUtils.exprType valargs)) ++ [(Right argexpr, (tfvec_elem . Var.varType) arg)])
-- Return the generate statement
; 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 (Left res) f args@[(Left zipped_f, _), (Left (CoreSyn.Var arg1), _), (Left (CoreSyn.Var arg2), _)] = do {
-- Setup the generate scheme
; len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) res
; let res_type = (tfvec_elem . Var.varType) res
-- TODO: Use something better than varToString
; let { label = mkVHDLExtId ("zipWithVector" ++ (varToUniqString res))
; n_id = mkVHDLBasicId "n"
; n_expr = idToVHDLExpr n_id
; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
; genScheme = AST.ForGn n_id range
-- Create the content of the generate statement: Applying the zipped_f to
-- each of the elements in arg1 and arg2, storing to each element in res
; resname = mkIndexedName (varToVHDLName res) n_expr
; (CoreSyn.Var real_f, already_mapped_args) = CoreSyn.collectArgs zipped_f
; valargs = get_val_args (Var.varType real_f) already_mapped_args
; argexpr1 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg1) n_expr
; argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg2) n_expr
} ;
; (app_concsms, used) <- genApplication (Right resname,res_type) real_f ((zip (map Left valargs) (map CoreUtils.exprType valargs)) ++ [(Right argexpr1, (tfvec_elem . Var.varType) arg1), (Right argexpr2, (tfvec_elem . Var.varType) arg2)])
-- Return the generate functions
; return ([AST.CSGSm $ AST.GenerateSm label genScheme [] app_concsms], used)
}
genFoldl :: BuiltinBuilder
genFoldl = genFold True
genFoldr :: BuiltinBuilder
genFoldr = genFold False
genFold :: Bool -> BuiltinBuilder
genFold left res f args@[folded_f, start, (vec, vecType)] = do
len <- MonadState.lift tsType $ tfp_to_int (tfvec_len_ty vecType)
genFold' len left res f args
genFold' :: Int -> Bool -> BuiltinBuilder
-- Special case for an empty input vector, just assign start to res
genFold' len left (Left res) _ [_, (start, _), vec] | len == 0 = do
[arg] <- argsToVHDLExprs [start]
return ([mkUncondAssign (Left res) arg], [])
genFold' len left (Left res) f [(Left folded_f,_), (start,startType), (vec,vecType)] = do
[vecExpr] <- argsToVHDLExprs [vec]
-- The vector length
--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
let (nvec, _) = Type.splitAppTy vecType
-- Put the type of the start value in nvec, this will be the type of our
-- temporary vector
let tmp_ty = Type.mkAppTy nvec startType
let error_msg = "\nGenerate.genFold': Can not construct temp vector for element type: " ++ pprString tmp_ty
-- TODO: Handle Nothing
Just tmp_vhdl_ty <- MonadState.lift tsType $ vhdlTy error_msg tmp_ty
-- Setup the generate scheme
let gen_label = mkVHDLExtId ("foldlVector" ++ (show vecExpr))
let block_label = mkVHDLExtId ("foldlVector" ++ (varToUniqString res))
let gen_range = if left then AST.ToRange (AST.PrimLit "0") len_min_expr
else AST.DownRange len_min_expr (AST.PrimLit "0")
let gen_scheme = AST.ForGn n_id gen_range
-- 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]
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], concat useds)
where
-- An id for the counter
n_id = mkVHDLBasicId "n"
n_cur = idToVHDLExpr n_id
-- An expression for previous n
n_prev = if left then (n_cur AST.:-: (AST.PrimLit "1"))
else (n_cur AST.:+: (AST.PrimLit "1"))
-- An id for the tmp result vector
tmp_id = mkVHDLBasicId "tmp"
tmp_name = AST.NSimple tmp_id
-- Generate parts of the fold
genFirstCell, genOtherCell :: TranslatorSession (AST.GenerateSm, [CoreSyn.CoreBndr])
genFirstCell = do
[AST.PrimName vecName, argexpr1] <- argsToVHDLExprs [vec,start]
let res_type = (tfvec_elem . Var.varType) res
len <- MonadState.lift tsType $ tfp_to_int $ tfvec_len_ty vecType
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")
else (AST.PrimLit $ show (len-1)))
-- Output to tmp[current n]
let resname = mkIndexedName tmp_name n_cur
-- Input from start
-- argexpr1 <- MonadState.lift tsType $ varToVHDLExpr start
-- Input from vec[current n]
let argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName vecName n_cur
let (CoreSyn.Var real_f, already_mapped_args) = CoreSyn.collectArgs folded_f
let valargs = get_val_args (Var.varType real_f) already_mapped_args
(app_concsms, used) <- genApplication (Right resname,res_type) real_f ((zip (map Left valargs) (map CoreUtils.exprType valargs)) ++ ( if left then
[(Right argexpr1, startType), (Right argexpr2, tfvec_elem vecType)]
else
[(Right argexpr2, tfvec_elem vecType), (Right argexpr1, startType)]
))
-- Return the conditional generate part
return (AST.GenerateSm cond_label cond_scheme [] app_concsms, used)
genOtherCell = do
[AST.PrimName vecName] <- argsToVHDLExprs [vec]
let res_type = (tfvec_elem . Var.varType) res
len <- MonadState.lift tsType $ tfp_to_int $ tfvec_len_ty vecType
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")
else (AST.PrimLit $ show (len-1)))
-- Output to tmp[current n]
let resname = mkIndexedName tmp_name n_cur
-- Input from tmp[previous n]
let argexpr1 = vhdlNameToVHDLExpr $ mkIndexedName tmp_name n_prev
-- Input from vec[current n]
let argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName vecName n_cur
let (CoreSyn.Var real_f, already_mapped_args) = CoreSyn.collectArgs folded_f
let valargs = get_val_args (Var.varType real_f) already_mapped_args
(app_concsms, used) <- genApplication (Right resname,res_type) real_f ((zip (map Left valargs) (map CoreUtils.exprType valargs)) ++ ( if left then
[(Right argexpr1, startType), (Right argexpr2, tfvec_elem vecType)]
else
[(Right argexpr2, tfvec_elem vecType), (Right argexpr1, startType)]
))
-- Return the conditional generate part
return (AST.GenerateSm cond_label cond_scheme [] app_concsms, used)
-- | Generate a generate statement for the builtin function "zip"
genZip :: BuiltinBuilder
genZip = genNoInsts genZip'
genZip' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [(Either CoreSyn.CoreExpr AST.Expr, Type.Type)] -> TranslatorSession [AST.ConcSm]
genZip' (Left res) f args@[(arg1,_), (arg2,_)] = do {
-- Setup the generate scheme
; len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) res
; res_htype <- MonadState.lift tsType $ mkHType "\nGenerate.genZip: Invalid result type" (tfvec_elem (Var.varType res))
; [AST.PrimName argName1, AST.PrimName argName2] <- argsToVHDLExprs [arg1,arg2]
-- TODO: Use something better than varToString
; let { label = mkVHDLExtId ("zipVector" ++ (varToUniqString res))
; n_id = mkVHDLBasicId "n"
; n_expr = idToVHDLExpr n_id
; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
; genScheme = AST.ForGn n_id range
; resname' = mkIndexedName (varToVHDLName res) n_expr
; argexpr1 = vhdlNameToVHDLExpr $ mkIndexedName argName1 n_expr
; argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName argName2 n_expr
; labels = getFieldLabels res_htype 0
}
; let { resnameA = mkSelectedName resname' (labels!!0)
; resnameB = mkSelectedName resname' (labels!!1)
; resA_assign = mkUncondAssign (Right resnameA) argexpr1
; resB_assign = mkUncondAssign (Right resnameB) argexpr2
} ;
-- Return the generate functions
; return [AST.CSGSm $ AST.GenerateSm label genScheme [] [resA_assign,resB_assign]]
}
-- | Generate a generate statement for the builtin function "fst"
genFst :: BuiltinBuilder
genFst = genNoInsts genFst'
genFst' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [(Either CoreSyn.CoreExpr AST.Expr, Type.Type)] -> TranslatorSession [AST.ConcSm]
genFst' res f args@[(arg,argType)] = do {
; arg_htype <- MonadState.lift tsType $ mkHType "\nGenerate.genFst: Invalid argument type" argType
; [AST.PrimName argExpr] <- argsToVHDLExprs [arg]
; let {
; labels = getFieldLabels arg_htype 0
; argexprA = vhdlNameToVHDLExpr $ mkSelectedName argExpr (labels!!0)
; assign = mkUncondAssign res argexprA
} ;
-- Return the generate functions
; return [assign]
}
-- | Generate a generate statement for the builtin function "snd"
genSnd :: BuiltinBuilder
genSnd = genNoInsts genSnd'
genSnd' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [(Either CoreSyn.CoreExpr AST.Expr, Type.Type)] -> TranslatorSession [AST.ConcSm]
genSnd' res f args@[(arg,argType)] = do {
; arg_htype <- MonadState.lift tsType $ mkHType "\nGenerate.genSnd: Invalid argument type" argType
; [AST.PrimName argExpr] <- argsToVHDLExprs [arg]
; let {
; labels = getFieldLabels arg_htype 0
; argexprB = vhdlNameToVHDLExpr $ mkSelectedName argExpr (labels!!1)
; assign = mkUncondAssign res argexprB
} ;
-- Return the generate functions
; return [assign]
}
-- | Generate a generate statement for the builtin function "unzip"
genUnzip :: BuiltinBuilder
genUnzip = genNoInsts genUnzip'
genUnzip' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [(Either CoreSyn.CoreExpr AST.Expr, Type.Type)] -> TranslatorSession [AST.ConcSm]
genUnzip' (Left res) f args@[(arg,argType)] = do
let error_msg = "\nGenerate.genUnzip: Cannot generate unzip call: " ++ pprString res ++ " = " ++ pprString f ++ " " ++ show arg
htype <- MonadState.lift tsType $ mkHType error_msg argType
-- Prepare a unconditional assignment, for the case when either part
-- of the unzip is a state variable, which will disappear in the
-- resulting VHDL, making the the unzip no longer required.
case htype of
-- A normal vector containing two-tuples
VecType _ arg_htype@(AggrType _ _ [[_, _]]) -> do {
-- Setup the generate scheme
; len <- MonadState.lift tsType $ tfp_to_int $ tfvec_len_ty argType
; res_htype <- MonadState.lift tsType $ mkHType "\nGenerate.genUnzip: Invalid result type" (Var.varType res)
; [AST.PrimName arg'] <- argsToVHDLExprs [arg]
-- TODO: Use something better than varToString
; let { label = mkVHDLExtId ("unzipVector" ++ (varToUniqString res))
; n_id = mkVHDLBasicId "n"
; n_expr = idToVHDLExpr n_id
; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
; genScheme = AST.ForGn n_id range
; resname' = varToVHDLName res
; argexpr' = mkIndexedName arg' n_expr
; reslabels = getFieldLabels res_htype 0
; arglabels = getFieldLabels arg_htype 0
} ;
; let { resnameA = mkIndexedName (mkSelectedName resname' (reslabels!!0)) n_expr
; resnameB = mkIndexedName (mkSelectedName resname' (reslabels!!1)) n_expr
; argexprA = vhdlNameToVHDLExpr $ mkSelectedName argexpr' (arglabels!!0)
; argexprB = vhdlNameToVHDLExpr $ mkSelectedName argexpr' (arglabels!!1)
; resA_assign = mkUncondAssign (Right resnameA) argexprA
; resB_assign = mkUncondAssign (Right resnameB) argexprB
} ;
-- Return the generate functions
; return [AST.CSGSm $ AST.GenerateSm label genScheme [] [resA_assign,resB_assign]]
}
-- Both elements of the tuple were state, so they've disappeared. No
-- need to do anything
VecType _ (AggrType _ _ []) -> return []
-- A vector containing aggregates with more than two elements?
VecType _ (AggrType _ _ _) -> error $ "Unzipping a value that is not a vector of two-tuples? Value: " ++ show arg ++ "\nType: " ++ pprString argType ++ "\nhType: " ++ show htype
-- One of the elements of the tuple was state, so there won't be a
-- tuple (record) in the VHDL output. We can just do a plain
-- assignment, then.
VecType _ _ -> do
[argexpr] <- argsToVHDLExprs [arg]
return [mkUncondAssign (Left res) argexpr]
_ -> error $ "Unzipping a value that is not a vector? Value: " ++ show arg ++ "\nType: " ++ pprString argType ++ "\nhtype: " ++ show htype
genCopy :: BuiltinBuilder
genCopy = genNoInsts genCopy'
genCopy' :: (Either CoreSyn.CoreBndr AST.VHDLName ) -> CoreSyn.CoreBndr -> [(Either CoreSyn.CoreExpr AST.Expr, Type.Type)] -> TranslatorSession [AST.ConcSm]
genCopy' (Left res) f [(arg,argType)] = do {
; [arg'] <- argsToVHDLExprs [arg]
; let { resExpr = AST.Aggregate [AST.ElemAssoc (Just AST.Others) arg']
; out_assign = mkUncondAssign (Left res) resExpr
}
; return [out_assign]
}
genCopyn :: BuiltinBuilder
genCopyn = genNoInsts genCopyn'
genCopyn' :: (Either CoreSyn.CoreBndr AST.VHDLName ) -> CoreSyn.CoreBndr -> [(Either CoreSyn.CoreExpr AST.Expr, Type.Type)] -> TranslatorSession [AST.ConcSm]
genCopyn' (Left res) f [arg0,(arg,argType)] = do {
; [arg'] <- argsToVHDLExprs [arg]
; let { resExpr = AST.Aggregate [AST.ElemAssoc (Just AST.Others) arg']
; out_assign = mkUncondAssign (Left res) resExpr
}
; return [out_assign]
}
genConcat :: BuiltinBuilder
genConcat = genNoInsts genConcat'
genConcat' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [(Either CoreSyn.CoreExpr AST.Expr, Type.Type)] -> TranslatorSession [AST.ConcSm]
genConcat' (Left res) f args@[(arg,argType)] = do {
-- Setup the generate scheme
; len1 <- MonadState.lift tsType $ tfp_to_int $ tfvec_len_ty argType
; let (_, nvec) = Type.splitAppTy argType
; len2 <- MonadState.lift tsType $ tfp_to_int $ tfvec_len_ty nvec
; [AST.PrimName argName] <- argsToVHDLExprs [arg]
-- TODO: Use something better than varToString
; let { label = mkVHDLExtId ("concatVector" ++ (varToUniqString res))
; n_id = mkVHDLBasicId "n"
; n_expr = idToVHDLExpr n_id
; fromRange = n_expr AST.:*: (AST.PrimLit $ show len2)
; genScheme = AST.ForGn n_id range
-- Create the content of the generate statement: Applying the mapped_f to
-- each of the elements in arg, storing to each element in res
; toRange = (n_expr AST.:*: (AST.PrimLit $ show len2)) AST.:+: (AST.PrimLit $ show (len2-1))
; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len1-1))
; resname = vecSlice fromRange toRange
; argexpr = vhdlNameToVHDLExpr $ mkIndexedName argName n_expr
; out_assign = mkUncondAssign (Right resname) argexpr
} ;
-- Return the generate statement
; return [AST.CSGSm $ AST.GenerateSm label genScheme [] [out_assign]]
}
where
vecSlice init last = AST.NSlice (AST.SliceName (varToVHDLName res)
(AST.ToRange init last))
genIteraten :: BuiltinBuilder
genIteraten dst f args = genIterate dst f (tail args)
genIterate :: BuiltinBuilder
genIterate = genIterateOrGenerate True
genGeneraten :: BuiltinBuilder
genGeneraten dst f args = genGenerate dst f (tail args)
genGenerate :: BuiltinBuilder
genGenerate = genIterateOrGenerate False
genIterateOrGenerate :: Bool -> BuiltinBuilder
genIterateOrGenerate iter (Left res) f args = do
len <- MonadState.lift tsType $ tfp_to_int ((tfvec_len_ty . Var.varType) res)
genIterateOrGenerate' len iter (Left res) f args
genIterateOrGenerate' :: Int -> Bool -> BuiltinBuilder
-- 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) f [(Left app_f,_), (start,startType)] = do
-- The vector length
-- 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
-- let (nvec, _) = splitAppTy (Var.varType vec)
-- -- Put the type of the start value in nvec, this will be the type of our
-- -- temporary vector
let tmp_ty = Var.varType res
let error_msg = "\nGenerate.genFold': Can not construct temp vector for element type: " ++ pprString tmp_ty
-- TODO: Handle Nothing
Just tmp_vhdl_ty <- MonadState.lift tsType $ vhdlTy error_msg tmp_ty
-- Setup the generate scheme
[startExpr] <- argsToVHDLExprs [start]
let gen_label = mkVHDLExtId ("iterateVector" ++ (show startExpr))
let block_label = mkVHDLExtId ("iterateVector" ++ (varToUniqString res))
let gen_range = AST.ToRange (AST.PrimLit "0") len_min_expr
let gen_scheme = AST.ForGn n_id gen_range
-- 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]
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], concat useds)
where
-- An id for the counter
n_id = mkVHDLBasicId "n"
n_cur = idToVHDLExpr n_id
-- An expression for previous n
n_prev = n_cur AST.:-: (AST.PrimLit "1")
-- An id for the tmp result vector
tmp_id = mkVHDLBasicId "tmp"
tmp_name = AST.NSimple tmp_id
-- Generate parts of the fold
genFirstCell, genOtherCell :: TranslatorSession (AST.GenerateSm, [CoreSyn.CoreBndr])
genFirstCell = do
let res_type = (tfvec_elem . Var.varType) res
let cond_label = mkVHDLExtId "firstcell"
-- if n == 0 or n == len-1
let cond_scheme = AST.IfGn $ n_cur AST.:=: (AST.PrimLit "0")
-- Output to tmp[current n]
let resname = mkIndexedName tmp_name n_cur
-- Input from start
[argexpr] <- argsToVHDLExprs [start]
let startassign = mkUncondAssign (Right resname) argexpr
let (CoreSyn.Var real_f, already_mapped_args) = CoreSyn.collectArgs app_f
let valargs = get_val_args (Var.varType real_f) already_mapped_args
(app_concsms, used) <- genApplication (Right resname, res_type) real_f ((zip (map Left valargs) (map CoreUtils.exprType valargs)) ++ [(Right argexpr, startType)])
-- Return the conditional generate part
let gensm = AST.GenerateSm cond_label cond_scheme [] (if iter then
[startassign]
else
app_concsms
)
return (gensm, used)
genOtherCell = do
let res_type = (tfvec_elem . Var.varType) res
let cond_label = mkVHDLExtId "othercell"
-- if n > 0 or n < len-1
let cond_scheme = AST.IfGn $ n_cur AST.:/=: (AST.PrimLit "0")
-- Output to tmp[current n]
let resname = mkIndexedName tmp_name n_cur
-- Input from tmp[previous n]
let argexpr = vhdlNameToVHDLExpr $ mkIndexedName tmp_name n_prev
let (CoreSyn.Var real_f, already_mapped_args) = CoreSyn.collectArgs app_f
let valargs = get_val_args (Var.varType real_f) already_mapped_args
(app_concsms, used) <- genApplication (Right resname, res_type) real_f ((zip (map Left valargs) (map CoreUtils.exprType valargs)) ++ [(Right argexpr, res_type)])
-- Return the conditional generate part
return (AST.GenerateSm cond_label cond_scheme [] app_concsms, used)
genBlockRAM :: BuiltinBuilder
genBlockRAM = genNoInsts $ genExprArgs genBlockRAM'
genBlockRAM' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [(AST.Expr,Type.Type)] -> TranslatorSession [AST.ConcSm]
genBlockRAM' (Left res) f args@[data_in,rdaddr,wraddr,wrenable] = do
-- Get the ram type
let (tup,data_out) = Type.splitAppTy (Var.varType res)
let (tup',ramvec) = Type.splitAppTy tup
let Just realram = Type.coreView ramvec
let Just (tycon, types) = Type.splitTyConApp_maybe realram
Just ram_vhdl_ty <- MonadState.lift tsType $ vhdlTy "wtf" (head types)
-- Make the intermediate vector
let ram_dec = AST.BDISD $ AST.SigDec ram_id ram_vhdl_ty Nothing
-- Get the data_out name
-- reslabels <- MonadState.lift tsType $ getFieldLabels (Var.varType res)
let resname = varToVHDLName res
-- let resname = mkSelectedName resname' (reslabels!!0)
let rdaddr_int = genExprFCall (mkVHDLBasicId toIntegerId) $ fst rdaddr
let argexpr = vhdlNameToVHDLExpr $ mkIndexedName (AST.NSimple ram_id) rdaddr_int
let assign = mkUncondAssign (Right resname) argexpr
let block_label = mkVHDLExtId ("blockRAM" ++ (varToUniqString res))
let block = AST.BlockSm block_label [] (AST.PMapAspect []) [ram_dec] [assign, mkUpdateProcSm]
return [AST.CSBSm block]
where
ram_id = mkVHDLBasicId "ram"
clockId = AST.unsafeVHDLBasicId "clock1"
mkUpdateProcSm :: AST.ConcSm
mkUpdateProcSm = AST.CSPSm $ AST.ProcSm proclabel [clockId] [statement]
where
proclabel = mkVHDLBasicId "updateRAM"
rising_edge = mkVHDLBasicId "rising_edge"
wraddr_int = genExprFCall (mkVHDLBasicId toIntegerId) $ fst wraddr
ramloc = mkIndexedName (AST.NSimple ram_id) wraddr_int
wform = AST.Wform [AST.WformElem (fst data_in) Nothing]
ramassign = AST.SigAssign ramloc wform
rising_edge_clk = genExprFCall rising_edge (AST.PrimName $ AST.NSimple clockId)
statement = AST.IfSm (AST.And rising_edge_clk $ fst wrenable) [ramassign] [] Nothing
genSplit :: BuiltinBuilder
genSplit = genNoInsts genSplit'
genSplit' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [(Either CoreSyn.CoreExpr AST.Expr, Type.Type)] -> TranslatorSession [AST.ConcSm]
genSplit' (Left res) f args@[(vecIn,vecInType)] = do {
; len <- MonadState.lift tsType $ tfp_to_int $ tfvec_len_ty vecInType
; res_htype <- MonadState.lift tsType $ mkHType "\nGenerate.genSplit': Invalid result type" (Var.varType res)
; [AST.PrimName argExpr] <- argsToVHDLExprs [vecIn]
; let {
; labels = getFieldLabels res_htype 0
; halflen = round ((fromIntegral len) / 2)
; rangeL = vecSlice argExpr (AST.PrimLit "0") (AST.PrimLit $ show (halflen - 1))
; rangeR = vecSlice argExpr (AST.PrimLit $ show halflen) (AST.PrimLit $ show (len - 1))
; resname = varToVHDLName res
; block_label = mkVHDLExtId ("split" ++ (varToUniqString res))
; resnameL = mkSelectedName resname (labels!!0)
; resnameR = mkSelectedName resname (labels!!1)
; argexprL = vhdlNameToVHDLExpr rangeL
; argexprR = vhdlNameToVHDLExpr rangeR
; out_assignL = mkUncondAssign (Right resnameL) argexprL
; out_assignR = mkUncondAssign (Right resnameR) argexprR
; block = AST.BlockSm block_label [] (AST.PMapAspect []) [] [out_assignL, out_assignR]
}
; return [AST.CSBSm block]
}
where
vecSlice n init last = AST.NSlice (AST.SliceName n (AST.ToRange init last))
genSll :: BuiltinBuilder
genSll = genNoInsts $ genExprArgs $ genExprRes genSll'
genSll' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [(AST.Expr, Type.Type)] -> TranslatorSession AST.Expr
genSll' res f [(arg1,_),(arg2,_)] = do {
; return $ (AST.Sll arg1 (genExprFCall (mkVHDLBasicId toIntegerId) arg2))
}
genSra :: BuiltinBuilder
genSra = genNoInsts $ genExprArgs $ genExprRes genSra'
genSra' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [(AST.Expr, Type.Type)] -> TranslatorSession AST.Expr
genSra' res f [(arg1,_),(arg2,_)] = do {
; return $ (genExprFCall2 (mkVHDLBasicId "shift_right") (arg1, (genExprFCall (mkVHDLBasicId toIntegerId) arg2)))
}
genI2bv :: BuiltinBuilder
genI2bv = genNoInsts $ genExprArgs $ genExprRes genI2bv'
genI2bv' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [(AST.Expr, Type.Type)] -> TranslatorSession AST.Expr
genI2bv' (Left res) f [(arg1,_)] = do {
; let resTy = Var.varType res
; let errorMsg = "\nGenerate.genS2bv': Can not construct vector type: " ++ pprString resTy
-- TODO: Handle Nothing
; Just tmpVhdlTy <- MonadState.lift tsType $ vhdlTy errorMsg resTy
; return $ (genExprFCall (mkVHDLBasicId $ AST.fromVHDLId tmpVhdlTy) arg1)
}
genBV2u :: BuiltinBuilder
genBV2u = genNoInsts $ genExprArgs $ genExprRes genBV2u'
genBV2u' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [(AST.Expr, Type.Type)] -> TranslatorSession AST.Expr
genBV2u' (Left res) f [(arg1,_)] = do {
; return $ (genExprFCall (mkVHDLBasicId "unsigned") arg1)
}
genBV2s :: BuiltinBuilder
genBV2s = genNoInsts $ genExprArgs $ genExprRes genBV2s'
genBV2s' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [(AST.Expr, Type.Type)] -> TranslatorSession AST.Expr
genBV2s' (Left res) f [(arg1,_)] = do {
; return $ (genExprFCall (mkVHDLBasicId "signed") arg1)
}
genTake :: BuiltinBuilder
genTake = genNoInsts $ genExprRes genTake'
genTake' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [(Either CoreSyn.CoreExpr AST.Expr, Type.Type)] -> TranslatorSession AST.Expr
genTake' res f [(arg1,arg1Type),(arg2,arg2Type)] = do {
; literal <- MonadState.lift tsType $ tfp_to_int arg1Type
; arg2expr <- argToVHDLExpr arg2
; let (AST.PrimName arg2name) = Maybe.fromMaybe (error $ "Generate.genTake': Expected variable reference, but found:" ++ either pprString show arg2) arg2expr
; arg2len <- MonadState.lift tsType $ tfp_to_int $ tfvec_len_ty arg2Type
; let minLit = min literal arg2len
; let takeVal = AST.PrimName (AST.NSlice (AST.SliceName arg2name (AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (minLit - 1)))))
; return takeVal
}
genDrop :: BuiltinBuilder
genDrop = genNoInsts $ genExprRes genDrop'
genDrop' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [(Either CoreSyn.CoreExpr AST.Expr, Type.Type)] -> TranslatorSession AST.Expr
genDrop' res f [(arg1,arg1Type),(arg2,arg2Type)] = do {
; literal <- MonadState.lift tsType $ tfp_to_int arg1Type
; arg2expr <- argToVHDLExpr arg2
; let (AST.PrimName arg2name) = Maybe.fromMaybe (error $ "Generate.genDrop': Expected variable reference, but found:" ++ either pprString show arg2) arg2expr
; arg2len <- MonadState.lift tsType $ tfp_to_int $ tfvec_len_ty arg2Type
; let dropVal = AST.PrimName (AST.NSlice (AST.SliceName arg2name (AST.ToRange (AST.PrimLit $ show literal) (AST.PrimLit $ show (arg2len - 1)))))
; return dropVal
}
genMaxIndex :: BuiltinBuilder
genMaxIndex = genNoInsts $ genExprRes genMaxIndex'
genMaxIndex' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [(Either CoreSyn.CoreExpr AST.Expr, Type.Type)] -> TranslatorSession AST.Expr
genMaxIndex' res f [(arg1,arg1Type)] = do {
; len <- MonadState.lift tsType $ tfp_to_int $ tfvec_len_ty arg1Type
; let bitsize = floor (logBase 2 (fromInteger (toInteger len)))
; return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId toUnsignedId))
[Nothing AST.:=>: AST.ADExpr (AST.PrimLit (show $ len - 1)), Nothing AST.:=>: AST.ADExpr( AST.PrimLit (show bitsize))]
}
-----------------------------------------------------------------------------
-- Function to generate VHDL for applications
-----------------------------------------------------------------------------
genApplication ::
(Either CoreSyn.CoreBndr AST.VHDLName, Type.Type) -- ^ Where to store the result?
-> CoreSyn.CoreBndr -- ^ The function to apply
-> [(Either CoreSyn.CoreExpr AST.Expr, Type.Type)] -- ^ The arguments to apply
-> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
-- ^ The corresponding VHDL concurrent statements and entities
-- instantiated.
genApplication (dst, dsttype) f args = do
nonemptydst <- case dst of
Left bndr -> hasNonEmptyType "\nGenerate.genApplication: " bndr
Right _ -> return True
if nonemptydst
then
if Var.isGlobalId f then
case Var.idDetails f of
IdInfo.DataConWorkId dc -> do -- case dst of
-- It's a datacon. Create a record from its arguments.
--Left bndr -> do
-- We have the bndr, so we can get at the type
htype_either <- MonadState.lift tsType $ mkHTypeEither dsttype
let argsNoState = filter (\(x,y) -> not (either hasStateType (\x -> False) x)) args
argsTransatable <- MonadState.lift tsType $ Monad.filterM (\(x,y) -> canTypeToVHDLType y) argsNoState
let dcs = datacons_for dsttype
case (dcs, map fst argsTransatable) of
-- This is a type with a single datacon and a single
-- argument, so no record is created (the type of the
-- binder becomes the type of the single argument).
([_], [arg]) -> do
[arg'] <- argsToVHDLExprs [arg]
return ([mkUncondAssign dst arg'], [])
-- In all other cases, a record type is created.
_ -> case htype_either of
Right htype@(AggrType _ etype _) -> do
let dc_i = datacon_index dsttype dc
let labels = getFieldLabels htype dc_i
arg_exprs <- argsToVHDLExprs (map fst argsNoState)
let (final_labels, final_exprs) = case getConstructorFieldLabel htype of
-- Only a single constructor
Nothing ->
(labels, arg_exprs)
-- Multiple constructors, so assign the
-- constructor used to the constructor field as
-- well.
Just dc_label ->
let { dc_index = getConstructorIndex (snd $ Maybe.fromMaybe (error $ "Generate.genApplication: expecting constructor but found none for: " ++ show htype) etype) (varToString f)
; dc_expr = AST.PrimLit $ show dc_index
} in (dc_label:labels, dc_expr:arg_exprs)
return (zipWith mkassign final_labels final_exprs, [])
where
mkassign :: AST.VHDLId -> AST.Expr -> AST.ConcSm
mkassign label arg =
let sel_name = mkSelectedName ((either varToVHDLName id) dst) label in
mkUncondAssign (Right sel_name) arg
-- Enumeration types have no arguments and are just
-- simple assignments
Right (EnumType _ _) ->
simple_assign
-- These builtin types are also enumeration types
Right (BuiltinType tyname) | tyname `elem` ["Bit", "Bool"] ->
simple_assign
Right _ -> error $ "Generate.genApplication(DataConWorkId): application does not result in a aggregate type? datacon: " ++ pprString f ++ " Args: " ++ concatMap (\(x,y) -> (either pprString show x) ++ (pprString y)) args
Left _ -> error $ "Generate.genApplication(DataConWorkId): Unrepresentable result type in datacon application? datacon: " ++ pprString f ++ " Args: " ++ concatMap (\(x,y) -> (either pprString show x) ++ (pprString y)) args
where
-- Simple uncoditional assignment, for (built-in)
-- enumeration types
simple_assign = do
expr <- MonadState.lift tsType $ dataconToVHDLExpr dc
return ([mkUncondAssign dst expr], [])
--
-- Right _ -> do
-- let dcs = datacons_for dsttype
-- error $ "\nGenerate.genApplication(DataConWorkId): Can't generate dataconstructor application without an original binder" ++ show dcs
IdInfo.DataConWrapId dc -> case dst of
-- It's a datacon. Create a record from its arguments.
Left bndr ->
case (Map.lookup (varToString f) globalNameTable) of
Just (arg_count, builder) ->
if length args == arg_count then
builder dst f args
else
error $ "\nGenerate.genApplication(DataConWrapId): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args
Nothing -> error $ "\nGenerate.genApplication(DataConWrapId): Can't generate dataconwrapper: " ++ (show dc)
Right _ -> error "\nGenerate.genApplication(DataConWrapId): Can't generate dataconwrapper application without an original binder"
IdInfo.VanillaId ->
-- It's a global value imported from elsewhere. These can be builtin
-- functions. Look up the function name in the name table and execute
-- the associated builder if there is any and the argument count matches
-- (this should always be the case if it typechecks, but just to be
-- sure...).
case (Map.lookup (varToString f) globalNameTable) of
Just (arg_count, builder) ->
if length args == arg_count then
builder dst f args
else
error $ "\nGenerate.genApplication(VanillaId): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args
Nothing -> do
top <- isTopLevelBinder f
if top then
do
-- Local binder that references a top level binding. Generate a
-- component instantiation.
signature <- getEntity f
args' <- argsToVHDLExprs (map fst args)
let entity_id = ent_id signature
-- TODO: Using show here isn't really pretty, but we'll need some
-- unique-ish value...
let label = "comp_ins_" ++ (either (prettyShow . varToVHDLName) prettyShow) dst
let portmaps = mkAssocElems args' ((either varToVHDLName id) dst) signature
clocksMap <- MonadState.get tsClocks
let clockDomains' = ((map snd) . Set.toList . Set.fromList . Map.elems) clocksMap
let clockDomains = if null clockDomains' then [1] else clockDomains'
return ([mkComponentInst label entity_id clockDomains portmaps], [f])
else
-- Not a top level binder, so this must be a local variable reference.
-- It should have a representable type (and thus, no arguments) and a
-- signal should be generated for it. Just generate an unconditional
-- assignment here.
-- FIXME : I DONT KNOW IF THE ABOVE COMMENT HOLDS HERE, SO FOR NOW JUST ERROR!
-- f' <- MonadState.lift tsType $ varToVHDLExpr f
-- return $ ([mkUncondAssign dst f'], [])
do errtype <- case dst of
Left bndr -> do
htype <- MonadState.lift tsType $ mkHTypeEither (Var.varType bndr)
return (show htype)
Right vhd -> return $ show vhd
error ("\nGenerate.genApplication(VanillaId): Using function from another module that is not a known builtin: " ++ (pprString f) ++ "::" ++ errtype)
IdInfo.ClassOpId cls ->
-- FIXME: Not looking for what instance this class op is called for
-- Is quite stupid of course.
case (Map.lookup (varToString f) globalNameTable) of
Just (arg_count, builder) ->
if length args == arg_count then
builder dst f args
else
error $ "\nGenerate.genApplication(ClassOpId): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args
Nothing -> error $ "\nGenerate.genApplication(ClassOpId): Using function from another module that is not a known builtin: " ++ pprString f
details -> error $ "\nGenerate.genApplication: Calling unsupported function " ++ pprString f ++ " with GlobalIdDetails " ++ pprString details
else do
top <- isTopLevelBinder f
if top then
do
-- Local binder that references a top level binding. Generate a
-- component instantiation.
signature <- getEntity f
args' <- argsToVHDLExprs (map fst args)
let entity_id = ent_id signature
-- TODO: Using show here isn't really pretty, but we'll need some
-- unique-ish value...
let label = "comp_ins_" ++ (either (prettyShow . varToVHDLName) prettyShow) dst
let portmaps = mkAssocElems args' ((either varToVHDLName id) dst) signature
clocksMap <- MonadState.get tsClocks
let clockDomains' = ((map snd) . Set.toList . Set.fromList . Map.elems) clocksMap
let clockDomains = if null clockDomains' then [1] else clockDomains'
return ([mkComponentInst label entity_id clockDomains portmaps], [f])
else
-- Not a top level binder, so this must be a local variable reference.
-- It should have a representable type (and thus, no arguments) and a
-- signal should be generated for it. Just generate an unconditional
-- assignment here.
do f' <- MonadState.lift tsType $ varToVHDLExpr f
return ([mkUncondAssign dst f'], [])
else -- Destination has empty type, don't generate anything
return ([], [])
canTypeToVHDLType :: Type.Type -> TypeSession Bool
canTypeToVHDLType ty = do
a <- vhdlTy "Generate.canTypeToVHDLType" ty
let b = case a of Nothing -> False ; Just _ -> True
return b
-----------------------------------------------------------------------------
-- Functions to generate functions dealing with vectors.
-----------------------------------------------------------------------------
-- Returns the VHDLId of the vector function with the given name for the given
-- element type. Generates -- this function if needed.
vectorFunId :: Type.Type -> String -> TypeSession AST.VHDLId
vectorFunId el_ty fname = do
let error_msg = "\nGenerate.vectorFunId: Can not construct vector function for element: " ++ pprString el_ty
-- TODO: Handle the Nothing case?
elemTM_maybe <- vhdlTy error_msg el_ty
let elemTM = Maybe.fromMaybe
(error $ "\nGenerate.vectorFunId: Cannot generate vector function \"" ++ fname ++ "\" for the empty type \"" ++ (pprString el_ty) ++ "\"")
elemTM_maybe
-- 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 <- MonadState.get tsTypeFuns
el_htype <- mkHType error_msg el_ty
case Map.lookup (UVecType el_htype, fname) typefuns of
-- Function already generated, just return it
Just (id, _) -> return id
-- Function not generated yet, generate it
Nothing -> do
let functions = genUnconsVectorFuns elemTM vectorTM
case lookup fname functions of
Just body -> do
MonadState.modify tsTypeFuns $ Map.insert (UVecType el_htype, 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
where
function_id = mkVHDLExtId fname
genUnconsVectorFuns :: AST.TypeMark -- ^ type of the vector elements
-> AST.TypeMark -- ^ type of the vector
-> [(String, (AST.SubProgBody, [String]))]
genUnconsVectorFuns elemTM vectorTM =
[ (exId, (AST.SubProgBody exSpec [] [exExpr],[]))
, (replaceId, (AST.SubProgBody replaceSpec [AST.SPVD replaceVar] [replaceExpr1,replaceExpr2,replaceRet],[]))
, (lastId, (AST.SubProgBody lastSpec [] [lastExpr],[]))
, (initId, (AST.SubProgBody initSpec [AST.SPVD initVar] [initExpr, initRet],[]))
, (minimumId, (AST.SubProgBody minimumSpec [] [minimumExpr],[]))
, (plusgtId, (AST.SubProgBody plusgtSpec [AST.SPVD plusgtVar] [plusgtExpr, plusgtRet],[]))
, (emptyId, (AST.SubProgBody emptySpec [AST.SPVD emptyVar] [emptyExpr],[]))
, (singletonId, (AST.SubProgBody singletonSpec [AST.SPVD singletonVar] [singletonRet],[]))
, (selId, (AST.SubProgBody selSpec [AST.SPVD selVar] [selFor, selRet],[]))
, (ltplusId, (AST.SubProgBody ltplusSpec [AST.SPVD ltplusVar] [ltplusExpr, ltplusRet],[]))
, (plusplusId, (AST.SubProgBody plusplusSpec [AST.SPVD plusplusVar] [plusplusExpr, plusplusRet],[]))
, (lengthTId, (AST.SubProgBody lengthTSpec [] [lengthTExpr],[]))
, (shiftIntoLId, (AST.SubProgBody shiftlSpec [AST.SPVD shiftlVar] [shiftlExpr, shiftlRet], [initId]))
, (shiftIntoRId, (AST.SubProgBody shiftrSpec [AST.SPVD shiftrVar] [shiftrExpr, shiftrRet], [tailId]))
, (nullId, (AST.SubProgBody nullSpec [] [nullExpr], []))
, (rotlId, (AST.SubProgBody rotlSpec [AST.SPVD rotlVar] [rotlExpr, rotlRet], [nullId, lastId, initId]))
, (rotrId, (AST.SubProgBody rotrSpec [AST.SPVD rotrVar] [rotrExpr, rotrRet], [nullId, tailId, headId]))
, (reverseId, (AST.SubProgBody reverseSpec [AST.SPVD reverseVar] [reverseFor, reverseRet], []))
]
where
ixPar = AST.unsafeVHDLBasicId "ix"
vecPar = AST.unsafeVHDLBasicId "vec"
vec1Par = AST.unsafeVHDLBasicId "vec1"
vec2Par = AST.unsafeVHDLBasicId "vec2"
nPar = AST.unsafeVHDLBasicId "n"
leftPar = AST.unsafeVHDLBasicId "nLeft"
rightPar = AST.unsafeVHDLBasicId "nRight"
iId = AST.unsafeVHDLBasicId "i"
iPar = iId
aPar = AST.unsafeVHDLBasicId "a"
fPar = AST.unsafeVHDLBasicId "f"
sPar = AST.unsafeVHDLBasicId "s"
resId = AST.unsafeVHDLBasicId "res"
exSpec = AST.Function (mkVHDLExtId exId) [AST.IfaceVarDec vecPar vectorTM,
AST.IfaceVarDec ixPar unsignedTM] elemTM
exExpr = AST.ReturnSm (Just $ AST.PrimName $ AST.NIndexed
(AST.IndexedName (AST.NSimple vecPar) [genExprFCall (mkVHDLBasicId toIntegerId) (AST.PrimName $ AST.NSimple ixPar)]))
replaceSpec = AST.Function (mkVHDLExtId replaceId) [ AST.IfaceVarDec vecPar vectorTM
, AST.IfaceVarDec iPar unsignedTM
, AST.IfaceVarDec aPar elemTM
] vectorTM
-- variable res : fsvec_x (0 to vec'length-1);
replaceVar =
AST.VarDec resId
(AST.SubtypeIn vectorTM
(Just $ AST.ConstraintIndex $ AST.IndexConstraint
[AST.ToRange (AST.PrimLit "0")
(AST.PrimName (AST.NAttribute $
AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
(AST.PrimLit "1")) ]))
Nothing
-- res AST.:= vec(0 to i-1) & a & vec(i+1 to length'vec-1)
replaceExpr1 = AST.NSimple resId AST.:= AST.PrimName (AST.NSimple vecPar)
replaceExpr2 = AST.NIndexed (AST.IndexedName (AST.NSimple resId) [genExprFCall (mkVHDLBasicId toIntegerId) (AST.PrimName $ AST.NSimple iPar)]) AST.:= AST.PrimName (AST.NSimple aPar)
replaceRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
vecSlice init last = AST.PrimName (AST.NSlice
(AST.SliceName
(AST.NSimple vecPar)
(AST.ToRange init last)))
lastSpec = AST.Function (mkVHDLExtId lastId) [AST.IfaceVarDec vecPar vectorTM] elemTM
-- return vec(vec'length-1);
lastExpr = AST.ReturnSm (Just (AST.PrimName $ AST.NIndexed (AST.IndexedName
(AST.NSimple vecPar)
[AST.PrimName (AST.NAttribute $
AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing)
AST.:-: AST.PrimLit "1"])))
initSpec = AST.Function (mkVHDLExtId initId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
-- variable res : fsvec_x (0 to vec'length-2);
initVar =
AST.VarDec resId
(AST.SubtypeIn vectorTM
(Just $ AST.ConstraintIndex $ AST.IndexConstraint
[AST.ToRange (AST.PrimLit "0")
(AST.PrimName (AST.NAttribute $
AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
(AST.PrimLit "2")) ]))
Nothing
-- resAST.:= vec(0 to vec'length-2)
initExpr = AST.NSimple resId AST.:= (vecSlice
(AST.PrimLit "0")
(AST.PrimName (AST.NAttribute $
AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing)
AST.:-: AST.PrimLit "2"))
initRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
minimumSpec = AST.Function (mkVHDLExtId minimumId) [AST.IfaceVarDec leftPar naturalTM,
AST.IfaceVarDec rightPar naturalTM ] naturalTM
minimumExpr = AST.IfSm ((AST.PrimName $ AST.NSimple leftPar) AST.:<: (AST.PrimName $ AST.NSimple rightPar))
[AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple leftPar)]
[]
(Just $ AST.Else [minimumExprRet])
where minimumExprRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple rightPar)
-- variable res : fsvec_x (0 to (minimum (n,vec'length))-1);
minLength = AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId minimumId))
[Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple nPar)
,Nothing AST.:=>: AST.ADExpr (AST.PrimName (AST.NAttribute $
AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))]
plusgtSpec = AST.Function (mkVHDLExtId plusgtId) [AST.IfaceVarDec aPar elemTM,
AST.IfaceVarDec vecPar vectorTM] vectorTM
-- variable res : fsvec_x (0 to vec'length);
plusgtVar =
AST.VarDec resId
(AST.SubtypeIn vectorTM
(Just $ AST.ConstraintIndex $ AST.IndexConstraint
[AST.ToRange (AST.PrimLit "0")
(AST.PrimName (AST.NAttribute $
AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))]))
Nothing
plusgtExpr = AST.NSimple resId AST.:=
((AST.PrimName $ AST.NSimple aPar) AST.:&:
(AST.PrimName $ AST.NSimple vecPar))
plusgtRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
emptySpec = AST.Function (mkVHDLExtId emptyId) [] vectorTM
emptyVar =
AST.VarDec resId
(AST.SubtypeIn vectorTM
(Just $ AST.ConstraintIndex $ AST.IndexConstraint
[AST.ToRange (AST.PrimLit "0") (AST.PrimLit "-1")]))
Nothing
emptyExpr = AST.ReturnSm (Just $ AST.PrimName (AST.NSimple resId))
singletonSpec = AST.Function (mkVHDLExtId singletonId) [AST.IfaceVarDec aPar elemTM ]
vectorTM
-- variable res : fsvec_x (0 to 0) := (others => a);
singletonVar =
AST.VarDec resId
(AST.SubtypeIn vectorTM
(Just $ AST.ConstraintIndex $ AST.IndexConstraint
[AST.ToRange (AST.PrimLit "0") (AST.PrimLit "0")]))
(Just $ AST.Aggregate [AST.ElemAssoc (Just AST.Others)
(AST.PrimName $ AST.NSimple aPar)])
singletonRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
selSpec = AST.Function (mkVHDLExtId selId) [AST.IfaceVarDec fPar naturalTM,
AST.IfaceVarDec sPar naturalTM,
AST.IfaceVarDec nPar naturalTM,
AST.IfaceVarDec vecPar vectorTM ] vectorTM
-- variable res : fsvec_x (0 to n-1);
selVar =
AST.VarDec resId
(AST.SubtypeIn vectorTM
(Just $ AST.ConstraintIndex $ AST.IndexConstraint
[AST.ToRange (AST.PrimLit "0")
((AST.PrimName (AST.NSimple nPar)) AST.:-:
(AST.PrimLit "1")) ])
)
Nothing
-- for i res'range loop
-- res(i) := vec(f+i*s);
-- end loop;
selFor = AST.ForSM iId (AST.AttribRange $ AST.AttribName (AST.NSimple resId) (AST.NSimple rangeId) Nothing) [selAssign]
-- res(i) := vec(f+i*s);
selAssign = let origExp = AST.PrimName (AST.NSimple fPar) AST.:+:
(AST.PrimName (AST.NSimple iId) AST.:*:
AST.PrimName (AST.NSimple sPar)) in
AST.NIndexed (AST.IndexedName (AST.NSimple resId) [AST.PrimName (AST.NSimple iId)]) AST.:=
(AST.PrimName $ AST.NIndexed (AST.IndexedName (AST.NSimple vecPar) [origExp]))
-- return res;
selRet = AST.ReturnSm (Just $ AST.PrimName (AST.NSimple resId))
ltplusSpec = AST.Function (mkVHDLExtId ltplusId) [AST.IfaceVarDec vecPar vectorTM,
AST.IfaceVarDec aPar elemTM] vectorTM
-- variable res : fsvec_x (0 to vec'length);
ltplusVar =
AST.VarDec resId
(AST.SubtypeIn vectorTM
(Just $ AST.ConstraintIndex $ AST.IndexConstraint
[AST.ToRange (AST.PrimLit "0")
(AST.PrimName (AST.NAttribute $
AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))]))
Nothing
ltplusExpr = AST.NSimple resId AST.:=
((AST.PrimName $ AST.NSimple vecPar) AST.:&:
(AST.PrimName $ AST.NSimple aPar))
ltplusRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
plusplusSpec = AST.Function (mkVHDLExtId plusplusId) [AST.IfaceVarDec vec1Par vectorTM,
AST.IfaceVarDec vec2Par vectorTM]
vectorTM
-- variable res : fsvec_x (0 to vec1'length + vec2'length -1);
plusplusVar =
AST.VarDec resId
(AST.SubtypeIn vectorTM
(Just $ AST.ConstraintIndex $ AST.IndexConstraint
[AST.ToRange (AST.PrimLit "0")
(AST.PrimName (AST.NAttribute $
AST.AttribName (AST.NSimple vec1Par) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:+:
AST.PrimName (AST.NAttribute $
AST.AttribName (AST.NSimple vec2Par) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
AST.PrimLit "1")]))
Nothing
plusplusExpr = AST.NSimple resId AST.:=
((AST.PrimName $ AST.NSimple vec1Par) AST.:&:
(AST.PrimName $ AST.NSimple vec2Par))
plusplusRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
lengthTSpec = AST.Function (mkVHDLExtId lengthTId) [AST.IfaceVarDec vecPar vectorTM] naturalTM
lengthTExpr = AST.ReturnSm (Just $ AST.PrimName (AST.NAttribute $
AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))
shiftlSpec = AST.Function (mkVHDLExtId shiftIntoLId) [AST.IfaceVarDec aPar elemTM,
AST.IfaceVarDec vecPar vectorTM] vectorTM
-- variable res : fsvec_x (0 to vec'length-1);
shiftlVar =
AST.VarDec resId
(AST.SubtypeIn vectorTM
(Just $ AST.ConstraintIndex $ AST.IndexConstraint
[AST.ToRange (AST.PrimLit "0")
(AST.PrimName (AST.NAttribute $
AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
(AST.PrimLit "1")) ]))
Nothing
-- res := a & init(vec)
shiftlExpr = AST.NSimple resId AST.:=
(AST.PrimName (AST.NSimple aPar) AST.:&:
(AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId initId))
[Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]))
shiftlRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
shiftrSpec = AST.Function (mkVHDLExtId shiftIntoRId) [AST.IfaceVarDec vecPar vectorTM,
AST.IfaceVarDec aPar elemTM ] vectorTM
-- variable res : fsvec_x (0 to vec'length-1);
shiftrVar =
AST.VarDec resId
(AST.SubtypeIn vectorTM
(Just $ AST.ConstraintIndex $ AST.IndexConstraint
[AST.ToRange (AST.PrimLit "0")
(AST.PrimName (AST.NAttribute $
AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
(AST.PrimLit "1")) ]))
Nothing
-- res := tail(vec) & a
shiftrExpr = AST.NSimple resId AST.:=
((AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId tailId))
[Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]) AST.:&:
(AST.PrimName (AST.NSimple aPar)))
shiftrRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
nullSpec = AST.Function (mkVHDLExtId nullId) [AST.IfaceVarDec vecPar vectorTM] booleanTM
-- return vec'length = 0
nullExpr = AST.ReturnSm (Just $
AST.PrimName (AST.NAttribute $
AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:=:
AST.PrimLit "0")
rotlSpec = AST.Function (mkVHDLExtId rotlId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
-- variable res : fsvec_x (0 to vec'length-1);
rotlVar =
AST.VarDec resId
(AST.SubtypeIn vectorTM
(Just $ AST.ConstraintIndex $ AST.IndexConstraint
[AST.ToRange (AST.PrimLit "0")
(AST.PrimName (AST.NAttribute $
AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
(AST.PrimLit "1")) ]))
Nothing
-- if null(vec) then res := vec else res := last(vec) & init(vec)
rotlExpr = AST.IfSm (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId nullId))
[Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)])
[AST.NSimple resId AST.:= (AST.PrimName $ AST.NSimple vecPar)]
[]
(Just $ AST.Else [rotlExprRet])
where rotlExprRet =
AST.NSimple resId AST.:=
((AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId lastId))
[Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]) AST.:&:
(AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId initId))
[Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]))
rotlRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
rotrSpec = AST.Function (mkVHDLExtId rotrId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
-- variable res : fsvec_x (0 to vec'length-1);
rotrVar =
AST.VarDec resId
(AST.SubtypeIn vectorTM
(Just $ AST.ConstraintIndex $ AST.IndexConstraint
[AST.ToRange (AST.PrimLit "0")
(AST.PrimName (AST.NAttribute $
AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
(AST.PrimLit "1")) ]))
Nothing
-- if null(vec) then res := vec else res := tail(vec) & head(vec)
rotrExpr = AST.IfSm (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId nullId))
[Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)])
[AST.NSimple resId AST.:= (AST.PrimName $ AST.NSimple vecPar)]
[]
(Just $ AST.Else [rotrExprRet])
where rotrExprRet =
AST.NSimple resId AST.:=
((AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId tailId))
[Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]) AST.:&:
(AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId headId))
[Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]))
rotrRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
reverseSpec = AST.Function (mkVHDLExtId reverseId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
reverseVar =
AST.VarDec resId
(AST.SubtypeIn vectorTM
(Just $ AST.ConstraintIndex $ AST.IndexConstraint
[AST.ToRange (AST.PrimLit "0")
(AST.PrimName (AST.NAttribute $
AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
(AST.PrimLit "1")) ]))
Nothing
-- for i in 0 to res'range loop
-- res(vec'length-i-1) := vec(i);
-- end loop;
reverseFor =
AST.ForSM iId (AST.AttribRange $ AST.AttribName (AST.NSimple resId) (AST.NSimple rangeId) Nothing) [reverseAssign]
-- res(vec'length-i-1) := vec(i);
reverseAssign = AST.NIndexed (AST.IndexedName (AST.NSimple resId) [destExp]) AST.:=
(AST.PrimName $ AST.NIndexed (AST.IndexedName (AST.NSimple vecPar)
[AST.PrimName $ AST.NSimple iId]))
where destExp = AST.PrimName (AST.NAttribute $ AST.AttribName (AST.NSimple vecPar)
(AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
AST.PrimName (AST.NSimple iId) AST.:-:
(AST.PrimLit "1")
-- return res;
reverseRet = AST.ReturnSm (Just $ AST.PrimName (AST.NSimple resId))
-----------------------------------------------------------------------------
-- 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, Type.Type)] -- ^ 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. If you add a name to this map, don't forget to add
-- it to VHDL.Constants/builtinIds as well.
globalNameTable :: NameTable
globalNameTable = Map.fromList
[ (exId , (2, genFCall True ) )
, (replaceId , (3, genFCall False ) )
, (headId , (1, genFCall True ) )
, (lastId , (1, genFCall True ) )
, (tailId , (1, genFCall False ) )
, (initId , (1, genFCall False ) )
, (takeId , (2, genTake ) )
, (dropId , (2, genDrop ) )
, (selId , (4, genFCall False ) )
, (plusgtId , (2, genFCall False ) )
, (ltplusId , (2, genFCall False ) )
, (plusplusId , (2, genFCall False ) )
, (mapId , (2, genMap ) )
, (zipWithId , (3, genZipWith ) )
, (foldlId , (3, genFoldl ) )
, (foldrId , (3, genFoldr ) )
, (zipId , (2, genZip ) )
, (unzipId , (1, genUnzip ) )
, (shiftIntoLId , (2, genFCall False ) )
, (shiftIntoRId , (2, genFCall False ) )
, (rotlId , (1, genFCall False ) )
, (rotrId , (1, genFCall False ) )
, (concatId , (1, genConcat ) )
, (reverseId , (1, genFCall False ) )
, (iteratenId , (3, genIteraten ) )
, (iterateId , (2, genIterate ) )
, (generatenId , (3, genGeneraten ) )
, (generateId , (2, genGenerate ) )
, (emptyId , (0, genFCall False ) )
, (singletonId , (1, genFCall False ) )
, (copynId , (2, genCopyn ) )
, (copyId , (1, genCopy ) )
, (lengthTId , (1, genFCall False ) )
, (nullId , (1, genFCall False ) )
, (hwxorId , (2, genOperator2 AST.Xor ) )
, (hwandId , (2, genOperator2 AST.And ) )
, (hworId , (2, genOperator2 AST.Or ) )
, (hwnotId , (1, genOperator1 AST.Not ) )
, (equalityId , (2, genOperator2 (AST.:=:) ) )
, (inEqualityId , (2, genOperator2 (AST.:/=:) ) )
, (ltId , (2, genOperator2 (AST.:<:) ) )
, (lteqId , (2, genOperator2 (AST.:<=:) ) )
, (gtId , (2, genOperator2 (AST.:>:) ) )
, (gteqId , (2, genOperator2 (AST.:>=:) ) )
, (boolOrId , (2, genOperator2 AST.Or ) )
, (boolAndId , (2, genOperator2 AST.And ) )
, (boolNot , (1, genOperator1 AST.Not ) )
, (plusId , (2, genOperator2 (AST.:+:) ) )
, (timesId , (2, genTimes ) )
, (negateId , (1, genNegation ) )
, (minusId , (2, genOperator2 (AST.:-:) ) )
, (fromSizedWordId , (1, genFromSizedWord ) )
, (fromRangedWordId , (1, genFromRangedWord ) )
, (fromIntegerId , (1, genFromInteger ) )
, (resizeWordId , (1, genResize ) )
, (resizeIntId , (1, genResize ) )
, (sizedIntId , (1, genSizedInt ) )
, (smallIntegerId , (1, genFromInteger ) )
, (fstId , (1, genFst ) )
, (sndId , (1, genSnd ) )
, (blockRAMId , (5, genBlockRAM ) )
, (splitId , (1, genSplit ) )
, (xorId , (2, genOperator2 AST.Xor ) )
, (shiftLId , (2, genSll ) )
, (shiftRId , (2, genSra ) )
, (s2bvId , (1, genI2bv ) )
, (u2bvId , (1, genI2bv ) )
, (bv2uId , (1, genBV2u ) )
, (bv2sId , (1, genBV2s ) )
, (maxIndexId , (1, genMaxIndex ) )
--, (tfvecId , (1, genTFVec ) )
, (minimumId , (2, error "\nFunction name: \"minimum\" is used internally, use another name"))
]