1 module CLasH.VHDL.Generate where
4 import qualified Data.List as List
5 import qualified Data.Map as Map
6 import qualified Control.Monad as Monad
8 import qualified Data.Either as Either
9 import qualified Data.Accessor.Monad.Trans.State as MonadState
12 import qualified Language.VHDL.AST as AST
15 import qualified CoreSyn
19 import qualified IdInfo
20 import qualified Literal
22 import qualified TyCon
23 import qualified CoreUtils
26 import CLasH.Translator.TranslatorTypes
27 import CLasH.VHDL.Constants
28 import CLasH.VHDL.VHDLTypes
29 import CLasH.VHDL.VHDLTools
31 import CLasH.Utils.Core.CoreTools
32 import CLasH.Utils.Pretty
33 import qualified CLasH.Normalize as Normalize
35 -----------------------------------------------------------------------------
36 -- Functions to generate VHDL for user-defined functions.
37 -----------------------------------------------------------------------------
39 -- | Create an entity for a given function
42 -> TranslatorSession Entity -- ^ The resulting entity
44 getEntity fname = makeCached fname tsEntities $ do
45 expr <- Normalize.getNormalized False fname
46 -- Split the normalized expression
47 let (args, binds, res) = Normalize.splitNormalized expr
48 -- Generate ports for all non-empty types
49 args' <- catMaybesM $ mapM mkMap args
50 -- TODO: Handle Nothing
52 count <- MonadState.get tsEntityCounter
53 let vhdl_id = mkVHDLBasicId $ varToString fname ++ "Component_" ++ show count
54 MonadState.set tsEntityCounter (count + 1)
55 let ent_decl = createEntityAST vhdl_id args' res'
56 let signature = Entity vhdl_id args' res' ent_decl
60 --[(SignalId, SignalInfo)]
62 -> TranslatorSession (Maybe Port)
65 --info = Maybe.fromMaybe
66 -- (error $ "Signal not found in the name map? This should not happen!")
68 -- Assume the bndr has a valid VHDL id already
71 error_msg = "\nVHDL.createEntity.mkMap: Can not create entity: " ++ pprString fname ++ "\nbecause no type can be created for port: " ++ pprString bndr
73 type_mark_maybe <- MonadState.lift tsType $ vhdlTy error_msg ty
74 case type_mark_maybe of
75 Just type_mark -> return $ Just (id, type_mark)
76 Nothing -> return Nothing
79 -- | Create the VHDL AST for an entity
81 AST.VHDLId -- ^ The name of the function
82 -> [Port] -- ^ The entity's arguments
83 -> Maybe Port -- ^ The entity's result
84 -> AST.EntityDec -- ^ The entity with the ent_decl filled in as well
86 createEntityAST vhdl_id args res =
87 AST.EntityDec vhdl_id ports
89 -- Create a basic Id, since VHDL doesn't grok filenames with extended Ids.
90 ports = map (mkIfaceSigDec AST.In) args
91 ++ (Maybe.maybeToList res_port)
92 ++ [clk_port,resetn_port]
93 -- Add a clk port if we have state
94 clk_port = AST.IfaceSigDec clockId AST.In std_logicTM
95 resetn_port = AST.IfaceSigDec resetId AST.In std_logicTM
96 res_port = fmap (mkIfaceSigDec AST.Out) res
98 -- | Create a port declaration
100 AST.Mode -- ^ The mode for the port (In / Out)
101 -> Port -- ^ The id and type for the port
102 -> AST.IfaceSigDec -- ^ The resulting port declaration
104 mkIfaceSigDec mode (id, ty) = AST.IfaceSigDec id mode ty
106 -- | Create an architecture for a given function
108 CoreSyn.CoreBndr -- ^ The function to get an architecture for
109 -> TranslatorSession (Architecture, [CoreSyn.CoreBndr])
110 -- ^ The architecture for this function
112 getArchitecture fname = makeCached fname tsArchitectures $ do
113 expr <- Normalize.getNormalized False fname
114 -- Split the normalized expression
115 let (args, binds, res) = Normalize.splitNormalized expr
117 -- Get the entity for this function
118 signature <- getEntity fname
119 let entity_id = ent_id signature
121 -- Create signal declarations for all binders in the let expression, except
122 -- for the output port (that will already have an output port declared in
124 sig_dec_maybes <- mapM (mkSigDec . fst) (filter ((/=res).fst) binds)
125 let sig_decs = Maybe.catMaybes sig_dec_maybes
126 -- Process each bind, resulting in info about state variables and concurrent
128 (state_vars, sms) <- Monad.mapAndUnzipM dobind binds
129 let (in_state_maybes, out_state_maybes) = unzip state_vars
130 let (statementss, used_entitiess) = unzip sms
131 -- Get initial state, if it's there
132 initSmap <- MonadState.get tsInitStates
133 let init_state = Map.lookup fname initSmap
134 -- Create a state proc, if needed
135 (state_proc, resbndr) <- case (Maybe.catMaybes in_state_maybes, Maybe.catMaybes out_state_maybes, init_state) of
136 ([in_state], [out_state], Nothing) -> do
137 nonEmpty <- hasNonEmptyType in_state
139 then error ("No initial state defined for: " ++ show fname)
141 ([in_state], [out_state], Just resetval) -> do
142 nonEmpty <- hasNonEmptyType in_state
144 then mkStateProcSm (in_state, out_state, resetval)
145 else error ("Initial state defined for function with only substate: " ++ show fname)
146 ([], [], Just _) -> error $ "Initial state defined for state-less function: " ++ show fname
147 ([], [], Nothing) -> return ([],[])
148 (ins, outs, res) -> error $ "Weird use of state in " ++ show fname ++ ". In: " ++ show ins ++ " Out: " ++ show outs
149 -- Join the create statements and the (optional) state_proc
150 let statements = concat statementss ++ state_proc
151 -- Create the architecture
152 let arch = AST.ArchBody (mkVHDLBasicId "structural") (AST.NSimple entity_id) (map AST.BDISD sig_decs) statements
153 let used_entities = (concat used_entitiess) ++ resbndr
154 return (arch, used_entities)
156 dobind :: (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The bind to process
157 -> TranslatorSession ((Maybe CoreSyn.CoreBndr, Maybe CoreSyn.CoreBndr), ([AST.ConcSm], [CoreSyn.CoreBndr]))
158 -- ^ ((Input state variable, output state variable), (statements, used entities))
159 -- newtype unpacking is just a cast
160 dobind (bndr, unpacked@(CoreSyn.Cast packed coercion))
161 | hasStateType packed && not (hasStateType unpacked)
162 = return ((Just bndr, Nothing), ([], []))
163 -- With simplCore, newtype packing is just a cast
164 dobind (bndr, packed@(CoreSyn.Cast unpacked@(CoreSyn.Var state) coercion))
165 | hasStateType packed && not (hasStateType unpacked)
166 = return ((Nothing, Just state), ([], []))
167 -- Without simplCore, newtype packing uses a data constructor
168 dobind (bndr, (CoreSyn.App (CoreSyn.App (CoreSyn.Var con) (CoreSyn.Type _)) (CoreSyn.Var state)))
170 = return ((Nothing, Just state), ([], []))
171 -- Anything else is handled by mkConcSm
174 return ((Nothing, Nothing), sms)
177 (CoreSyn.CoreBndr, CoreSyn.CoreBndr, CoreSyn.CoreBndr) -- ^ The current state, new state and reset variables
178 -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr]) -- ^ The resulting statements
179 mkStateProcSm (old, new, res) = do
180 let error_msg = "\nVHDL.mkSigDec: Can not make signal declaration for type: \n" ++ pprString res
181 type_mark_old_maybe <- MonadState.lift tsType $ vhdlTy error_msg (Var.varType old)
182 let type_mark_old = Maybe.fromMaybe
183 (error $ "\nGenerate.mkStateProcSm: empty type for state? Type: " ++ pprString (Var.varType old))
185 type_mark_res_maybe <- MonadState.lift tsType $ vhdlTy error_msg (Var.varType res)
186 let type_mark_res' = Maybe.fromMaybe
187 (error $ "\nGenerate.mkStateProcSm: empty type for initial state? Type: " ++ pprString (Var.varType res))
189 let type_mark_res = if type_mark_old == type_mark_res' then
192 error $ "Initial state has different type than state type, state type: " ++ show type_mark_old ++ ", init type: " ++ show type_mark_res'
193 let resvalid = mkVHDLExtId $ varToString res ++ "val"
194 let resvaldec = AST.BDISD $ AST.SigDec resvalid type_mark_res Nothing
195 let reswform = AST.Wform [AST.WformElem (AST.PrimName $ AST.NSimple resvalid) Nothing]
196 let res_assign = AST.SigAssign (varToVHDLName old) reswform
197 let blocklabel = mkVHDLBasicId "state"
198 let statelabel = mkVHDLBasicId "stateupdate"
199 let rising_edge = AST.NSimple $ mkVHDLBasicId "rising_edge"
200 let wform = AST.Wform [AST.WformElem (AST.PrimName $ varToVHDLName new) Nothing]
201 let clk_assign = AST.SigAssign (varToVHDLName old) wform
202 let rising_edge_clk = AST.PrimFCall $ AST.FCall rising_edge [Nothing AST.:=>: (AST.ADName $ AST.NSimple clockId)]
203 let resetn_is_low = (AST.PrimName $ AST.NSimple resetId) AST.:=: (AST.PrimLit "'0'")
204 signature <- getEntity res
205 let entity_id = ent_id signature
206 let reslabel = "resetval_" ++ ((prettyShow . varToVHDLName) res)
207 let portmaps = mkAssocElems [] (AST.NSimple resvalid) signature
208 let reset_statement = mkComponentInst reslabel entity_id portmaps
209 let clk_statement = [AST.ElseIf rising_edge_clk [clk_assign]]
210 let statement = AST.IfSm resetn_is_low [res_assign] clk_statement Nothing
211 let stateupdate = AST.CSPSm $ AST.ProcSm statelabel [clockId,resetId,resvalid] [statement]
212 let block = AST.CSBSm $ AST.BlockSm blocklabel [] (AST.PMapAspect []) [resvaldec] [reset_statement,stateupdate]
213 return ([block],[res])
215 -- | Transforms a core binding into a VHDL concurrent statement
217 (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The binding to process
218 -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
219 -- ^ The corresponding VHDL concurrent statements and entities
223 -- Ignore Cast expressions, they should not longer have any meaning as long as
224 -- the type works out. Throw away state repacking
225 mkConcSm (bndr, to@(CoreSyn.Cast from ty))
226 | hasStateType to && hasStateType from
228 mkConcSm (bndr, CoreSyn.Cast expr ty) = mkConcSm (bndr, expr)
230 -- Simple a = b assignments are just like applications, but without arguments.
231 -- We can't just generate an unconditional assignment here, since b might be a
232 -- top level binding (e.g., a function with no arguments).
233 mkConcSm (bndr, CoreSyn.Var v) = do
234 genApplication (Left bndr, Var.varType bndr) v []
236 mkConcSm (bndr, app@(CoreSyn.App _ _))= do
237 let (CoreSyn.Var f, args) = CoreSyn.collectArgs app
238 let valargs = get_val_args (Var.varType f) args
239 genApplication (Left bndr, Var.varType bndr) f (zip (map Left valargs) (map CoreUtils.exprType valargs))
241 -- A single alt case must be a selector. This means the scrutinee is a simple
242 -- variable, the alternative is a dataalt with a single non-wild binder that
244 mkConcSm (bndr, expr@(CoreSyn.Case (CoreSyn.Var scrut) b ty [alt]))
245 -- Don't generate VHDL for substate extraction
246 | hasStateType bndr = return ([], [])
249 (CoreSyn.DataAlt dc, bndrs, (CoreSyn.Var sel_bndr)) -> do
250 nonemptysel <- hasNonEmptyType sel_bndr
253 bndrs' <- Monad.filterM hasNonEmptyType bndrs
254 case List.elemIndex sel_bndr bndrs' of
256 htypeScrt <- MonadState.lift tsType $ mkHTypeEither (Var.varType scrut)
257 htypeBndr <- MonadState.lift tsType $ mkHTypeEither (Var.varType bndr)
258 case htypeScrt == htypeBndr of
260 let sel_name = varToVHDLName scrut
261 let sel_expr = AST.PrimName sel_name
262 return ([mkUncondAssign (Left bndr) sel_expr], [])
265 Right htype@(AggrType _ _ _) -> do
266 let dc_i = datacon_index (Id.idType scrut) dc
267 let labels = getFieldLabels htype dc_i
268 let label = labels!!sel_i
269 let sel_name = mkSelectedName (varToVHDLName scrut) label
270 let sel_expr = AST.PrimName sel_name
271 return ([mkUncondAssign (Left bndr) sel_expr], [])
272 _ -> do -- error $ "DIE!"
273 let sel_name = varToVHDLName scrut
274 let sel_expr = AST.PrimName sel_name
275 return ([mkUncondAssign (Left bndr) sel_expr], [])
276 Nothing -> error $ "\nVHDL.mkConcSM: Not in normal form: Not a selector case: result is not one of the binders\n" ++ (pprString expr)
278 -- A selector case that selects a state value, ignore it.
281 _ -> error $ "\nVHDL.mkConcSM: Not in normal form: Not a selector case:\n" ++ (pprString expr)
283 -- Multiple case alt become conditional assignments and have only wild
284 -- binders in the alts and only variables in the case values and a variable
285 -- for a scrutinee. We check the constructor of the second alt, since the
286 -- first is the default case, if there is any.
287 mkConcSm (bndr, expr@(CoreSyn.Case (CoreSyn.Var scrut) _ _ alts)) = do
288 htype <- MonadState.lift tsType $ mkHType ("\nVHDL.mkConcSm: Unrepresentable scrutinee type? Expression: " ++ pprString expr) scrut
289 -- Turn the scrutinee into a VHDLExpr
290 scrut_expr <- MonadState.lift tsType $ varToVHDLExpr scrut
291 (enums, cmp) <- case htype of
292 EnumType _ enums -> do
293 -- Enumeration type, compare with the scrutinee directly
294 return (map stringToVHDLExpr enums, scrut_expr)
295 AggrType _ (Just (name, EnumType _ enums)) _ -> do
296 -- Extract the enumeration field from the aggregation
297 let sel_name = mkSelectedName (varToVHDLName scrut) (mkVHDLBasicId name)
298 let sel_expr = AST.PrimName sel_name
299 return (map stringToVHDLExpr enums, sel_expr)
300 (BuiltinType "Bit") -> do
301 let enums = [AST.PrimLit "'1'", AST.PrimLit "'0'"]
302 return (enums, scrut_expr)
303 (BuiltinType "Bool") -> do
304 let enums = [AST.PrimLit "true", AST.PrimLit "false"]
305 return (enums, scrut_expr)
306 _ -> error $ "\nSelector case on weird scrutinee: " ++ pprString scrut ++ " scrutinee type: " ++ pprString (Id.idType scrut)
307 -- Omit first condition, which is the default. Look up each altcon in
308 -- the enums list from the HType to find the actual enum value names.
309 let altcons = map (\(CoreSyn.DataAlt dc, _, _) -> enums!!(datacon_index scrut dc)) (tail alts)
310 -- Compare the (constructor field of the) scrutinee with each of the
312 let cond_exprs = map (\x -> cmp AST.:=: x) altcons
313 -- Rotate expressions to the left, so that the expression related to the default case is the last
314 exprs <- MonadState.lift tsType $ mapM (varToVHDLExpr . (\(_,_,CoreSyn.Var expr) -> expr)) ((tail alts) ++ [head alts])
315 return ([mkAltsAssign (Left bndr) cond_exprs exprs], [])
317 mkConcSm (_, CoreSyn.Case _ _ _ _) = error "\nVHDL.mkConcSm: Not in normal form: Case statement does not have a simple variable as scrutinee"
318 mkConcSm (bndr, expr) = error $ "\nVHDL.mkConcSM: Unsupported binding in let expression: " ++ pprString bndr ++ " = " ++ pprString expr
320 -----------------------------------------------------------------------------
321 -- Functions to generate VHDL for builtin functions
322 -----------------------------------------------------------------------------
324 -- | A function to wrap a builder-like function that expects its arguments to
326 genExprArgs wrap dst func args = do
327 args' <- argsToVHDLExprs (map fst args)
328 wrap dst func (zip args' (map snd args))
330 -- | Turn the all lefts into VHDL Expressions.
331 argsToVHDLExprs :: [Either CoreSyn.CoreExpr AST.Expr] -> TranslatorSession [AST.Expr]
332 argsToVHDLExprs = catMaybesM . (mapM argToVHDLExpr)
334 argToVHDLExpr :: Either CoreSyn.CoreExpr AST.Expr -> TranslatorSession (Maybe AST.Expr)
335 argToVHDLExpr (Left expr) = MonadState.lift tsType $ do
336 let errmsg = "Generate.argToVHDLExpr: Using non-representable type? Should not happen!"
337 ty_maybe <- vhdlTy errmsg expr
340 vhdl_expr <- varToVHDLExpr $ exprToVar expr
341 return $ Just vhdl_expr
342 Nothing -> return Nothing
344 argToVHDLExpr (Right expr) = return $ Just expr
346 -- A function to wrap a builder-like function that generates no component
349 (dst -> func -> args -> TranslatorSession [AST.ConcSm])
350 -> (dst -> func -> args -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr]))
351 genNoInsts wrap dst func args = do
352 concsms <- wrap dst func args
355 -- | A function to wrap a builder-like function that expects its arguments to
358 -- (dst -> func -> [Var.Var] -> res)
359 -- -> (dst -> func -> [Either CoreSyn.CoreExpr AST.Expr] -> res)
360 -- genVarArgs wrap = genCoreArgs $ \dst func args -> let
361 -- args' = map exprToVar args
363 -- wrap dst func args'
365 -- | A function to wrap a builder-like function that expects its arguments to
366 -- be core expressions.
368 (dst -> func -> [CoreSyn.CoreExpr] -> res)
369 -> (dst -> func -> [(Either CoreSyn.CoreExpr AST.Expr, Type.Type)] -> res)
370 genCoreArgs wrap dst func args = wrap dst func args'
372 -- Check (rather crudely) that all arguments are CoreExprs
373 args' = case Either.partitionEithers (map fst args) of
374 (exprargs, []) -> exprargs
375 (exprsargs, rest) -> error $ "\nGenerate.genCoreArgs: expect core expression arguments but found ast exprs:" ++ (show rest)
377 -- | A function to wrap a builder-like function that produces an expression
378 -- and expects it to be assigned to the destination.
380 ((Either CoreSyn.CoreBndr AST.VHDLName) -> func -> [arg] -> TranslatorSession AST.Expr)
381 -> ((Either CoreSyn.CoreBndr AST.VHDLName) -> func -> [arg] -> TranslatorSession [AST.ConcSm])
382 genExprRes wrap dst func args = do
383 expr <- wrap dst func args
384 return [mkUncondAssign dst expr]
386 -- | Generate a binary operator application. The first argument should be a
387 -- constructor from the AST.Expr type, e.g. AST.And.
388 genOperator2 :: (AST.Expr -> AST.Expr -> AST.Expr) -> BuiltinBuilder
389 genOperator2 op = genNoInsts $ genExprArgs $ genExprRes (genOperator2' op)
390 genOperator2' :: (AST.Expr -> AST.Expr -> AST.Expr) -> dst -> CoreSyn.CoreBndr -> [(AST.Expr, Type.Type)] -> TranslatorSession AST.Expr
391 genOperator2' op _ f [(arg1,_), (arg2,_)] = return $ op arg1 arg2
393 -- | Generate a unary operator application
394 genOperator1 :: (AST.Expr -> AST.Expr) -> BuiltinBuilder
395 genOperator1 op = genNoInsts $ genExprArgs $ genExprRes (genOperator1' op)
396 genOperator1' :: (AST.Expr -> AST.Expr) -> dst -> CoreSyn.CoreBndr -> [(AST.Expr, Type.Type)] -> TranslatorSession AST.Expr
397 genOperator1' op _ f [(arg,_)] = return $ op arg
399 -- | Generate a unary operator application
400 genNegation :: BuiltinBuilder
401 genNegation = genNoInsts $ genExprRes genNegation'
402 genNegation' :: dst -> CoreSyn.CoreBndr -> [(Either CoreSyn.CoreExpr AST.Expr, Type.Type)] -> TranslatorSession AST.Expr
403 genNegation' _ f [(arg,argType)] = do
404 [arg1] <- argsToVHDLExprs [arg]
405 let (tycon, args) = Type.splitTyConApp argType
406 let name = Name.getOccString (TyCon.tyConName tycon)
408 "Signed" -> return $ AST.Neg arg1
409 otherwise -> error $ "\nGenerate.genNegation': Negation not allowed for type: " ++ show name
411 -- | Generate a function call from the destination binder, function name and a
412 -- list of expressions (its arguments)
413 genFCall :: Bool -> BuiltinBuilder
414 genFCall switch = genNoInsts $ genExprArgs $ genExprRes (genFCall' switch)
415 genFCall' :: Bool -> Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [(AST.Expr, Type.Type)] -> TranslatorSession AST.Expr
416 genFCall' switch (Left res) f args = do
417 let fname = varToString f
418 let el_ty = if switch then (Var.varType res) else ((tfvec_elem . Var.varType) res)
419 id <- MonadState.lift tsType $ vectorFunId el_ty fname
420 return $ AST.PrimFCall $ AST.FCall (AST.NSimple id) $
421 map (\exp -> Nothing AST.:=>: AST.ADExpr exp) (map fst args)
422 genFCall' _ (Right name) _ _ = error $ "\nGenerate.genFCall': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
424 genFromSizedWord :: BuiltinBuilder
425 genFromSizedWord = genNoInsts $ genExprArgs genFromSizedWord'
426 genFromSizedWord' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [(AST.Expr, Type.Type)] -> TranslatorSession [AST.ConcSm]
427 genFromSizedWord' (Left res) f args@[(arg,_)] =
428 return [mkUncondAssign (Left res) arg]
429 -- let fname = varToString f
430 -- return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId toIntegerId)) $
431 -- map (\exp -> Nothing AST.:=>: AST.ADExpr exp) args
432 genFromSizedWord' (Right name) _ _ = error $ "\nGenerate.genFromSizedWord': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
434 genFromRangedWord :: BuiltinBuilder
435 genFromRangedWord = genNoInsts $ genExprArgs $ genExprRes genFromRangedWord'
436 genFromRangedWord' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [(AST.Expr, Type.Type)] -> TranslatorSession AST.Expr
437 genFromRangedWord' (Left res) f [(arg,_)] = do {
438 ; let { ty = Var.varType res
439 ; (tycon, args) = Type.splitTyConApp ty
440 ; name = Name.getOccString (TyCon.tyConName tycon)
442 ; len <- MonadState.lift tsType $ tfp_to_int (sized_word_len_ty ty)
443 ; return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId resizeId))
444 [Nothing AST.:=>: AST.ADExpr arg, Nothing AST.:=>: AST.ADExpr( AST.PrimLit (show len))]
446 genFromRangedWord' (Right name) _ _ = error $ "\nGenerate.genFromRangedWord': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
448 genResize :: BuiltinBuilder
449 genResize = genNoInsts $ genExprArgs $ genExprRes genResize'
450 genResize' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [(AST.Expr, Type.Type)] -> TranslatorSession AST.Expr
451 genResize' (Left res) f [(arg,_)] = do {
452 ; let { ty = Var.varType res
453 ; (tycon, args) = Type.splitTyConApp ty
454 ; name = Name.getOccString (TyCon.tyConName tycon)
456 ; len <- case name of
457 "Signed" -> MonadState.lift tsType $ tfp_to_int (sized_int_len_ty ty)
458 "Unsigned" -> MonadState.lift tsType $ tfp_to_int (sized_word_len_ty ty)
459 ; return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId resizeId))
460 [Nothing AST.:=>: AST.ADExpr arg, Nothing AST.:=>: AST.ADExpr( AST.PrimLit (show len))]
462 genResize' (Right name) _ _ = error $ "\nGenerate.genFromSizedWord': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
464 genTimes :: BuiltinBuilder
465 genTimes = genNoInsts $ genExprArgs $ genExprRes genTimes'
466 genTimes' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [(AST.Expr, Type.Type)] -> TranslatorSession AST.Expr
467 genTimes' (Left res) f [(arg1,_),(arg2,_)] = do {
468 ; let { ty = Var.varType res
469 ; (tycon, args) = Type.splitTyConApp ty
470 ; name = Name.getOccString (TyCon.tyConName tycon)
472 ; len <- case name of
473 "Signed" -> MonadState.lift tsType $ tfp_to_int (sized_int_len_ty ty)
474 "Unsigned" -> MonadState.lift tsType $ tfp_to_int (sized_word_len_ty ty)
475 "Index" -> do { ubound <- MonadState.lift tsType $ tfp_to_int (ranged_word_bound_ty ty)
476 ; let bitsize = floor (logBase 2 (fromInteger (toInteger ubound)))
479 ; return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId resizeId))
480 [Nothing AST.:=>: AST.ADExpr (arg1 AST.:*: arg2), Nothing AST.:=>: AST.ADExpr( AST.PrimLit (show len))]
482 genTimes' (Right name) _ _ = error $ "\nGenerate.genTimes': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
484 -- fromInteger turns an Integer into a Num instance. Since Integer is
485 -- not representable and is only allowed for literals, the actual
486 -- Integer should be inlined entirely into the fromInteger argument.
487 genFromInteger :: BuiltinBuilder
488 genFromInteger = genNoInsts $ genCoreArgs $ genExprRes genFromInteger'
489 genFromInteger' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [CoreSyn.CoreExpr] -> TranslatorSession AST.Expr
490 genFromInteger' (Left res) f args = do
491 let ty = Var.varType res
492 let (tycon, tyargs) = Type.splitTyConApp ty
493 let name = Name.getOccString (TyCon.tyConName tycon)
495 "Signed" -> MonadState.lift tsType $ tfp_to_int (sized_int_len_ty ty)
496 "Unsigned" -> MonadState.lift tsType $ tfp_to_int (sized_word_len_ty ty)
498 bound <- MonadState.lift tsType $ tfp_to_int (ranged_word_bound_ty ty)
499 return $ floor (logBase 2 (fromInteger (toInteger (bound)))) + 1
500 let fname = case name of "Signed" -> toSignedId ; "Unsigned" -> toUnsignedId ; "Index" -> toUnsignedId
502 [integer] -> do -- The type and dictionary arguments are removed by genApplication
503 literal <- getIntegerLiteral integer
504 return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId fname))
505 [Nothing AST.:=>: AST.ADExpr (AST.PrimLit (show literal)), Nothing AST.:=>: AST.ADExpr( AST.PrimLit (show len))]
506 _ -> error $ "\nGenerate.genFromInteger': Wrong number of arguments to genInteger. Applying " ++ pprString f ++ " to " ++ pprString args
508 genFromInteger' (Right name) _ _ = error $ "\nGenerate.genFromInteger': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
510 genSizedInt :: BuiltinBuilder
511 genSizedInt = genFromInteger
514 -- This function is useful for use with vectorTH, since that generates
515 -- explicit references to the TFVec constructor (which is normally
516 -- hidden). Below implementation is probably not current anymore, but
517 -- kept here in case we start using vectorTH again.
518 -- | Generate a Builder for the builtin datacon TFVec
519 genTFVec :: BuiltinBuilder
520 genTFVec (Left res) f [Left (CoreSyn.Let (CoreSyn.Rec letBinders) letRes)] = do {
521 -- Generate Assignments for all the binders
522 ; letAssigns <- mapM genBinderAssign letBinders
523 -- Generate assignments for the result (which might be another let binding)
524 ; (resBinders,resAssignments) <- genResAssign letRes
525 -- Get all the Assigned binders
526 ; let assignedBinders = Maybe.catMaybes (map fst letAssigns)
527 -- Make signal names for all the assigned binders
528 ; sigs <- mapM (\x -> MonadState.lift tsType $ varToVHDLExpr x) (assignedBinders ++ resBinders)
529 -- Assign all the signals to the resulting vector
530 ; let { vecsigns = mkAggregateSignal sigs
531 ; vecassign = mkUncondAssign (Left res) vecsigns
533 -- Generate all the signal declaration for the assigned binders
534 ; sig_dec_maybes <- mapM mkSigDec (assignedBinders ++ resBinders)
535 ; let { sig_decs = map (AST.BDISD) (Maybe.catMaybes $ sig_dec_maybes)
536 -- Setup the VHDL Block
537 ; block_label = mkVHDLExtId ("TFVec_" ++ show (varToString res))
538 ; block = AST.BlockSm block_label [] (AST.PMapAspect []) sig_decs ((concat (map snd letAssigns)) ++ resAssignments ++ [vecassign])
540 -- Return the block statement coressponding to the TFVec literal
541 ; return $ [AST.CSBSm block]
544 genBinderAssign :: (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -> TranslatorSession (Maybe CoreSyn.CoreBndr, [AST.ConcSm])
545 -- For now we only translate applications
546 genBinderAssign (bndr, app@(CoreSyn.App _ _)) = do
547 let (CoreSyn.Var f, args) = CoreSyn.collectArgs app
548 let valargs = get_val_args (Var.varType f) args
549 apps <- genApplication (Left bndr) f (map Left valargs)
550 return (Just bndr, apps)
551 genBinderAssign _ = return (Nothing,[])
552 genResAssign :: CoreSyn.CoreExpr -> TranslatorSession ([CoreSyn.CoreBndr], [AST.ConcSm])
553 genResAssign app@(CoreSyn.App _ letexpr) = do
555 (CoreSyn.Let (CoreSyn.Rec letbndrs) letres) -> do
556 letapps <- mapM genBinderAssign letbndrs
557 let bndrs = Maybe.catMaybes (map fst letapps)
558 let app = (map snd letapps)
559 (vars, apps) <- genResAssign letres
560 return ((bndrs ++ vars),((concat app) ++ apps))
561 otherwise -> return ([],[])
562 genResAssign _ = return ([],[])
564 genTFVec (Left res) f [Left app@(CoreSyn.App _ _)] = do {
565 ; let { elems = reduceCoreListToHsList app
566 -- Make signal names for all the binders
567 ; binders = map (\expr -> case expr of
569 otherwise -> error $ "\nGenerate.genTFVec: Cannot generate TFVec: "
570 ++ show res ++ ", with elems:\n" ++ show elems ++ "\n" ++ pprString elems) elems
572 ; sigs <- mapM (\x -> MonadState.lift tsType $ varToVHDLExpr x) binders
573 -- Assign all the signals to the resulting vector
574 ; let { vecsigns = mkAggregateSignal sigs
575 ; vecassign = mkUncondAssign (Left res) vecsigns
576 -- Setup the VHDL Block
577 ; block_label = mkVHDLExtId ("TFVec_" ++ show (varToString res))
578 ; block = AST.BlockSm block_label [] (AST.PMapAspect []) [] [vecassign]
580 -- Return the block statement coressponding to the TFVec literal
581 ; return $ [AST.CSBSm block]
584 genTFVec (Left name) _ [Left xs] = error $ "\nGenerate.genTFVec: Cannot generate TFVec: " ++ show name ++ ", with elems:\n" ++ show xs ++ "\n" ++ pprString xs
586 genTFVec (Right name) _ _ = error $ "\nGenerate.genTFVec: Cannot generate TFVec assigned to VHDLName: " ++ show name
588 -- | Generate a generate statement for the builtin function "map"
589 genMap :: BuiltinBuilder
590 genMap (Left res) f [(Left mapped_f, _), (Left (CoreSyn.Var arg), _)] = do {
591 -- mapped_f must be a CoreExpr (since we can't represent functions as VHDL
592 -- expressions). arg must be a CoreExpr (and should be a CoreSyn.Var), since
593 -- we must index it (which we couldn't if it was a VHDL Expr, since only
594 -- VHDLNames can be indexed).
595 -- Setup the generate scheme
596 ; len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) res
597 ; let res_type = (tfvec_elem . Var.varType) res
598 -- TODO: Use something better than varToString
599 ; let { label = mkVHDLExtId ("mapVector" ++ (varToString res))
600 ; n_id = mkVHDLBasicId "n"
601 ; n_expr = idToVHDLExpr n_id
602 ; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
603 ; genScheme = AST.ForGn n_id range
604 -- Create the content of the generate statement: Applying the mapped_f to
605 -- each of the elements in arg, storing to each element in res
606 ; resname = mkIndexedName (varToVHDLName res) n_expr
607 ; argexpr = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg) n_expr
608 ; (CoreSyn.Var real_f, already_mapped_args) = CoreSyn.collectArgs mapped_f
609 ; valargs = get_val_args (Var.varType real_f) already_mapped_args
611 ; (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)])
612 -- Return the generate statement
613 ; return ([AST.CSGSm $ AST.GenerateSm label genScheme [] app_concsms], used)
616 genMap' (Right name) _ _ = error $ "\nGenerate.genMap': Cannot generate map function call assigned to a VHDLName: " ++ show name
618 genZipWith :: BuiltinBuilder
619 genZipWith (Left res) f args@[(Left zipped_f, _), (Left (CoreSyn.Var arg1), _), (Left (CoreSyn.Var arg2), _)] = do {
620 -- Setup the generate scheme
621 ; len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) res
622 ; let res_type = (tfvec_elem . Var.varType) res
623 -- TODO: Use something better than varToString
624 ; let { label = mkVHDLExtId ("zipWithVector" ++ (varToString res))
625 ; n_id = mkVHDLBasicId "n"
626 ; n_expr = idToVHDLExpr n_id
627 ; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
628 ; genScheme = AST.ForGn n_id range
629 -- Create the content of the generate statement: Applying the zipped_f to
630 -- each of the elements in arg1 and arg2, storing to each element in res
631 ; resname = mkIndexedName (varToVHDLName res) n_expr
632 ; (CoreSyn.Var real_f, already_mapped_args) = CoreSyn.collectArgs zipped_f
633 ; valargs = get_val_args (Var.varType real_f) already_mapped_args
634 ; argexpr1 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg1) n_expr
635 ; argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg2) n_expr
637 ; (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)])
638 -- Return the generate functions
639 ; return ([AST.CSGSm $ AST.GenerateSm label genScheme [] app_concsms], used)
642 genFoldl :: BuiltinBuilder
643 genFoldl = genFold True
645 genFoldr :: BuiltinBuilder
646 genFoldr = genFold False
648 genFold :: Bool -> BuiltinBuilder
649 genFold left res f args@[folded_f, start, (vec, vecType)] = do
650 len <- MonadState.lift tsType $ tfp_to_int (tfvec_len_ty vecType)
651 genFold' len left res f args
653 genFold' :: Int -> Bool -> BuiltinBuilder
654 -- Special case for an empty input vector, just assign start to res
655 genFold' len left (Left res) _ [_, (start, _), vec] | len == 0 = do
656 [arg] <- argsToVHDLExprs [start]
657 return ([mkUncondAssign (Left res) arg], [])
659 genFold' len left (Left res) f [(Left folded_f,_), (start,startType), (vec,vecType)] = do
660 [vecExpr] <- argsToVHDLExprs [vec]
662 --len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) vec
663 -- An expression for len-1
664 let len_min_expr = (AST.PrimLit $ show (len-1))
665 -- evec is (TFVec n), so it still needs an element type
666 let (nvec, _) = Type.splitAppTy vecType
667 -- Put the type of the start value in nvec, this will be the type of our
669 let tmp_ty = Type.mkAppTy nvec startType
670 let error_msg = "\nGenerate.genFold': Can not construct temp vector for element type: " ++ pprString tmp_ty
671 -- TODO: Handle Nothing
672 Just tmp_vhdl_ty <- MonadState.lift tsType $ vhdlTy error_msg tmp_ty
673 -- Setup the generate scheme
674 let gen_label = mkVHDLExtId ("foldlVector" ++ (show vecExpr))
675 let block_label = mkVHDLExtId ("foldlVector" ++ (varToString res))
676 let gen_range = if left then AST.ToRange (AST.PrimLit "0") len_min_expr
677 else AST.DownRange len_min_expr (AST.PrimLit "0")
678 let gen_scheme = AST.ForGn n_id gen_range
679 -- Make the intermediate vector
680 let tmp_dec = AST.BDISD $ AST.SigDec tmp_id tmp_vhdl_ty Nothing
681 -- Create the generate statement
682 cells' <- sequence [genFirstCell, genOtherCell]
683 let (cells, useds) = unzip cells'
684 let gen_sm = AST.GenerateSm gen_label gen_scheme [] (map AST.CSGSm cells)
685 -- Assign tmp[len-1] or tmp[0] to res
686 let out_assign = mkUncondAssign (Left res) $ vhdlNameToVHDLExpr (if left then
687 (mkIndexedName tmp_name (AST.PrimLit $ show (len-1))) else
688 (mkIndexedName tmp_name (AST.PrimLit "0")))
689 let block = AST.BlockSm block_label [] (AST.PMapAspect []) [tmp_dec] [AST.CSGSm gen_sm, out_assign]
690 return ([AST.CSBSm block], concat useds)
692 -- An id for the counter
693 n_id = mkVHDLBasicId "n"
694 n_cur = idToVHDLExpr n_id
695 -- An expression for previous n
696 n_prev = if left then (n_cur AST.:-: (AST.PrimLit "1"))
697 else (n_cur AST.:+: (AST.PrimLit "1"))
698 -- An id for the tmp result vector
699 tmp_id = mkVHDLBasicId "tmp"
700 tmp_name = AST.NSimple tmp_id
701 -- Generate parts of the fold
702 genFirstCell, genOtherCell :: TranslatorSession (AST.GenerateSm, [CoreSyn.CoreBndr])
704 [AST.PrimName vecName, argexpr1] <- argsToVHDLExprs [vec,start]
705 let res_type = (tfvec_elem . Var.varType) res
706 len <- MonadState.lift tsType $ tfp_to_int $ tfvec_len_ty vecType
707 let cond_label = mkVHDLExtId "firstcell"
708 -- if n == 0 or n == len-1
709 let cond_scheme = AST.IfGn $ n_cur AST.:=: (if left then (AST.PrimLit "0")
710 else (AST.PrimLit $ show (len-1)))
711 -- Output to tmp[current n]
712 let resname = mkIndexedName tmp_name n_cur
714 -- argexpr1 <- MonadState.lift tsType $ varToVHDLExpr start
715 -- Input from vec[current n]
716 let argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName vecName n_cur
717 let (CoreSyn.Var real_f, already_mapped_args) = CoreSyn.collectArgs folded_f
718 let valargs = get_val_args (Var.varType real_f) already_mapped_args
719 (app_concsms, used) <- genApplication (Right resname,res_type) real_f ((zip (map Left valargs) (map CoreUtils.exprType valargs)) ++ ( if left then
720 [(Right argexpr1, startType), (Right argexpr2, tfvec_elem vecType)]
722 [(Right argexpr2, tfvec_elem vecType), (Right argexpr1, startType)]
724 -- Return the conditional generate part
725 return (AST.GenerateSm cond_label cond_scheme [] app_concsms, used)
728 [AST.PrimName vecName] <- argsToVHDLExprs [vec]
729 let res_type = (tfvec_elem . Var.varType) res
730 len <- MonadState.lift tsType $ tfp_to_int $ tfvec_len_ty vecType
731 let cond_label = mkVHDLExtId "othercell"
732 -- if n > 0 or n < len-1
733 let cond_scheme = AST.IfGn $ n_cur AST.:/=: (if left then (AST.PrimLit "0")
734 else (AST.PrimLit $ show (len-1)))
735 -- Output to tmp[current n]
736 let resname = mkIndexedName tmp_name n_cur
737 -- Input from tmp[previous n]
738 let argexpr1 = vhdlNameToVHDLExpr $ mkIndexedName tmp_name n_prev
739 -- Input from vec[current n]
740 let argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName vecName n_cur
741 let (CoreSyn.Var real_f, already_mapped_args) = CoreSyn.collectArgs folded_f
742 let valargs = get_val_args (Var.varType real_f) already_mapped_args
743 (app_concsms, used) <- genApplication (Right resname,res_type) real_f ((zip (map Left valargs) (map CoreUtils.exprType valargs)) ++ ( if left then
744 [(Right argexpr1, startType), (Right argexpr2, tfvec_elem vecType)]
746 [(Right argexpr2, tfvec_elem vecType), (Right argexpr1, startType)]
748 -- Return the conditional generate part
749 return (AST.GenerateSm cond_label cond_scheme [] app_concsms, used)
751 -- | Generate a generate statement for the builtin function "zip"
752 genZip :: BuiltinBuilder
753 genZip = genNoInsts genZip'
754 genZip' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [(Either CoreSyn.CoreExpr AST.Expr, Type.Type)] -> TranslatorSession [AST.ConcSm]
755 genZip' (Left res) f args@[(arg1,_), (arg2,_)] = do {
756 -- Setup the generate scheme
757 ; len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) res
758 ; res_htype <- MonadState.lift tsType $ mkHType "\nGenerate.genZip: Invalid result type" (tfvec_elem (Var.varType res))
759 ; [AST.PrimName argName1, AST.PrimName argName2] <- argsToVHDLExprs [arg1,arg2]
760 -- TODO: Use something better than varToString
761 ; let { label = mkVHDLExtId ("zipVector" ++ (varToString res))
762 ; n_id = mkVHDLBasicId "n"
763 ; n_expr = idToVHDLExpr n_id
764 ; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
765 ; genScheme = AST.ForGn n_id range
766 ; resname' = mkIndexedName (varToVHDLName res) n_expr
767 ; argexpr1 = vhdlNameToVHDLExpr $ mkIndexedName argName1 n_expr
768 ; argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName argName2 n_expr
769 ; labels = getFieldLabels res_htype 0
771 ; let { resnameA = mkSelectedName resname' (labels!!0)
772 ; resnameB = mkSelectedName resname' (labels!!1)
773 ; resA_assign = mkUncondAssign (Right resnameA) argexpr1
774 ; resB_assign = mkUncondAssign (Right resnameB) argexpr2
776 -- Return the generate functions
777 ; return [AST.CSGSm $ AST.GenerateSm label genScheme [] [resA_assign,resB_assign]]
780 -- | Generate a generate statement for the builtin function "fst"
781 genFst :: BuiltinBuilder
782 genFst = genNoInsts genFst'
783 genFst' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [(Either CoreSyn.CoreExpr AST.Expr, Type.Type)] -> TranslatorSession [AST.ConcSm]
784 genFst' res f args@[(arg,argType)] = do {
785 ; arg_htype <- MonadState.lift tsType $ mkHType "\nGenerate.genFst: Invalid argument type" argType
786 ; [AST.PrimName argExpr] <- argsToVHDLExprs [arg]
788 ; labels = getFieldLabels arg_htype 0
789 ; argexprA = vhdlNameToVHDLExpr $ mkSelectedName argExpr (labels!!0)
790 ; assign = mkUncondAssign res argexprA
792 -- Return the generate functions
796 -- | Generate a generate statement for the builtin function "snd"
797 genSnd :: BuiltinBuilder
798 genSnd = genNoInsts genSnd'
799 genSnd' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [(Either CoreSyn.CoreExpr AST.Expr, Type.Type)] -> TranslatorSession [AST.ConcSm]
800 genSnd' (Left res) f args@[(arg,argType)] = do {
801 ; arg_htype <- MonadState.lift tsType $ mkHType "\nGenerate.genSnd: Invalid argument type" argType
802 ; [AST.PrimName argExpr] <- argsToVHDLExprs [arg]
804 ; labels = getFieldLabels arg_htype 0
805 ; argexprB = vhdlNameToVHDLExpr $ mkSelectedName argExpr (labels!!1)
806 ; assign = mkUncondAssign (Left res) argexprB
808 -- Return the generate functions
812 -- | Generate a generate statement for the builtin function "unzip"
813 genUnzip :: BuiltinBuilder
814 genUnzip = genNoInsts genUnzip'
815 genUnzip' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [(Either CoreSyn.CoreExpr AST.Expr, Type.Type)] -> TranslatorSession [AST.ConcSm]
816 genUnzip' (Left res) f args@[(arg,argType)] = do
817 let error_msg = "\nGenerate.genUnzip: Cannot generate unzip call: " ++ pprString res ++ " = " ++ pprString f ++ " " ++ show arg
818 htype <- MonadState.lift tsType $ mkHType error_msg argType
819 -- Prepare a unconditional assignment, for the case when either part
820 -- of the unzip is a state variable, which will disappear in the
821 -- resulting VHDL, making the the unzip no longer required.
823 -- A normal vector containing two-tuples
824 VecType _ (AggrType _ _ [_, _]) -> do {
825 -- Setup the generate scheme
826 ; len <- MonadState.lift tsType $ tfp_to_int $ tfvec_len_ty argType
827 ; arg_htype <- MonadState.lift tsType $ mkHType "\nGenerate.genUnzip: Invalid argument type" argType
828 ; res_htype <- MonadState.lift tsType $ mkHType "\nGenerate.genUnzip: Invalid result type" (Var.varType res)
829 ; [AST.PrimName arg'] <- argsToVHDLExprs [arg]
830 -- TODO: Use something better than varToString
831 ; let { label = mkVHDLExtId ("unzipVector" ++ (varToString res))
832 ; n_id = mkVHDLBasicId "n"
833 ; n_expr = idToVHDLExpr n_id
834 ; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
835 ; genScheme = AST.ForGn n_id range
836 ; resname' = varToVHDLName res
837 ; argexpr' = mkIndexedName arg' n_expr
838 ; reslabels = getFieldLabels res_htype 0
839 ; arglabels = getFieldLabels arg_htype 0
841 ; let { resnameA = mkIndexedName (mkSelectedName resname' (reslabels!!0)) n_expr
842 ; resnameB = mkIndexedName (mkSelectedName resname' (reslabels!!1)) n_expr
843 ; argexprA = vhdlNameToVHDLExpr $ mkSelectedName argexpr' (arglabels!!0)
844 ; argexprB = vhdlNameToVHDLExpr $ mkSelectedName argexpr' (arglabels!!1)
845 ; resA_assign = mkUncondAssign (Right resnameA) argexprA
846 ; resB_assign = mkUncondAssign (Right resnameB) argexprB
848 -- Return the generate functions
849 ; return [AST.CSGSm $ AST.GenerateSm label genScheme [] [resA_assign,resB_assign]]
851 -- Both elements of the tuple were state, so they've disappeared. No
852 -- need to do anything
853 VecType _ (AggrType _ _ []) -> return []
854 -- A vector containing aggregates with more than two elements?
855 VecType _ (AggrType _ _ _) -> error $ "Unzipping a value that is not a vector of two-tuples? Value: " ++ show arg ++ "\nType: " ++ pprString argType
856 -- One of the elements of the tuple was state, so there won't be a
857 -- tuple (record) in the VHDL output. We can just do a plain
860 [argexpr] <- argsToVHDLExprs [arg]
861 return [mkUncondAssign (Left res) argexpr]
862 _ -> error $ "Unzipping a value that is not a vector? Value: " ++ show arg ++ "\nType: " ++ pprString argType ++ "\nhtype: " ++ show htype
864 genCopy :: BuiltinBuilder
865 genCopy = genNoInsts genCopy'
866 genCopy' :: (Either CoreSyn.CoreBndr AST.VHDLName ) -> CoreSyn.CoreBndr -> [(Either CoreSyn.CoreExpr AST.Expr, Type.Type)] -> TranslatorSession [AST.ConcSm]
867 genCopy' (Left res) f [(arg,argType)] = do {
868 ; [arg'] <- argsToVHDLExprs [arg]
869 ; let { resExpr = AST.Aggregate [AST.ElemAssoc (Just AST.Others) arg']
870 ; out_assign = mkUncondAssign (Left res) resExpr
872 ; return [out_assign]
875 genConcat :: BuiltinBuilder
876 genConcat = genNoInsts genConcat'
877 genConcat' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [(Either CoreSyn.CoreExpr AST.Expr, Type.Type)] -> TranslatorSession [AST.ConcSm]
878 genConcat' (Left res) f args@[(arg,argType)] = do {
879 -- Setup the generate scheme
880 ; len1 <- MonadState.lift tsType $ tfp_to_int $ tfvec_len_ty argType
881 ; let (_, nvec) = Type.splitAppTy argType
882 ; len2 <- MonadState.lift tsType $ tfp_to_int $ tfvec_len_ty nvec
883 ; [AST.PrimName argName] <- argsToVHDLExprs [arg]
884 -- TODO: Use something better than varToString
885 ; let { label = mkVHDLExtId ("concatVector" ++ (varToString res))
886 ; n_id = mkVHDLBasicId "n"
887 ; n_expr = idToVHDLExpr n_id
888 ; fromRange = n_expr AST.:*: (AST.PrimLit $ show len2)
889 ; genScheme = AST.ForGn n_id range
890 -- Create the content of the generate statement: Applying the mapped_f to
891 -- each of the elements in arg, storing to each element in res
892 ; toRange = (n_expr AST.:*: (AST.PrimLit $ show len2)) AST.:+: (AST.PrimLit $ show (len2-1))
893 ; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len1-1))
894 ; resname = vecSlice fromRange toRange
895 ; argexpr = vhdlNameToVHDLExpr $ mkIndexedName argName n_expr
896 ; out_assign = mkUncondAssign (Right resname) argexpr
898 -- Return the generate statement
899 ; return [AST.CSGSm $ AST.GenerateSm label genScheme [] [out_assign]]
902 vecSlice init last = AST.NSlice (AST.SliceName (varToVHDLName res)
903 (AST.ToRange init last))
905 genIteraten :: BuiltinBuilder
906 genIteraten dst f args = genIterate dst f (tail args)
908 genIterate :: BuiltinBuilder
909 genIterate = genIterateOrGenerate True
911 genGeneraten :: BuiltinBuilder
912 genGeneraten dst f args = genGenerate dst f (tail args)
914 genGenerate :: BuiltinBuilder
915 genGenerate = genIterateOrGenerate False
917 genIterateOrGenerate :: Bool -> BuiltinBuilder
918 genIterateOrGenerate iter (Left res) f args = do
919 len <- MonadState.lift tsType $ tfp_to_int ((tfvec_len_ty . Var.varType) res)
920 genIterateOrGenerate' len iter (Left res) f args
922 genIterateOrGenerate' :: Int -> Bool -> BuiltinBuilder
923 -- Special case for an empty input vector, just assign start to res
924 genIterateOrGenerate' len iter (Left res) _ [app_f, start] | len == 0 = return ([mkUncondAssign (Left res) (AST.PrimLit "\"\"")], [])
926 genIterateOrGenerate' len iter (Left res) f [(Left app_f,_), (start,startType)] = do
928 -- len <- MonadState.lift tsType $ tfp_to_int ((tfvec_len_ty . Var.varType) res)
929 -- An expression for len-1
930 let len_min_expr = (AST.PrimLit $ show (len-1))
931 -- -- evec is (TFVec n), so it still needs an element type
932 -- let (nvec, _) = splitAppTy (Var.varType vec)
933 -- -- Put the type of the start value in nvec, this will be the type of our
934 -- -- temporary vector
935 let tmp_ty = Var.varType res
936 let error_msg = "\nGenerate.genFold': Can not construct temp vector for element type: " ++ pprString tmp_ty
937 -- TODO: Handle Nothing
938 Just tmp_vhdl_ty <- MonadState.lift tsType $ vhdlTy error_msg tmp_ty
939 -- Setup the generate scheme
940 [startExpr] <- argsToVHDLExprs [start]
941 let gen_label = mkVHDLExtId ("iterateVector" ++ (show startExpr))
942 let block_label = mkVHDLExtId ("iterateVector" ++ (varToString res))
943 let gen_range = AST.ToRange (AST.PrimLit "0") len_min_expr
944 let gen_scheme = AST.ForGn n_id gen_range
945 -- Make the intermediate vector
946 let tmp_dec = AST.BDISD $ AST.SigDec tmp_id tmp_vhdl_ty Nothing
947 -- Create the generate statement
948 cells' <- sequence [genFirstCell, genOtherCell]
949 let (cells, useds) = unzip cells'
950 let gen_sm = AST.GenerateSm gen_label gen_scheme [] (map AST.CSGSm cells)
951 -- Assign tmp[len-1] or tmp[0] to res
952 let out_assign = mkUncondAssign (Left res) $ vhdlNameToVHDLExpr tmp_name
953 let block = AST.BlockSm block_label [] (AST.PMapAspect []) [tmp_dec] [AST.CSGSm gen_sm, out_assign]
954 return ([AST.CSBSm block], concat useds)
956 -- An id for the counter
957 n_id = mkVHDLBasicId "n"
958 n_cur = idToVHDLExpr n_id
959 -- An expression for previous n
960 n_prev = n_cur AST.:-: (AST.PrimLit "1")
961 -- An id for the tmp result vector
962 tmp_id = mkVHDLBasicId "tmp"
963 tmp_name = AST.NSimple tmp_id
964 -- Generate parts of the fold
965 genFirstCell, genOtherCell :: TranslatorSession (AST.GenerateSm, [CoreSyn.CoreBndr])
967 let res_type = (tfvec_elem . Var.varType) res
968 let cond_label = mkVHDLExtId "firstcell"
969 -- if n == 0 or n == len-1
970 let cond_scheme = AST.IfGn $ n_cur AST.:=: (AST.PrimLit "0")
971 -- Output to tmp[current n]
972 let resname = mkIndexedName tmp_name n_cur
974 [argexpr] <- argsToVHDLExprs [start]
975 let startassign = mkUncondAssign (Right resname) argexpr
976 let (CoreSyn.Var real_f, already_mapped_args) = CoreSyn.collectArgs app_f
977 let valargs = get_val_args (Var.varType real_f) already_mapped_args
978 (app_concsms, used) <- genApplication (Right resname, res_type) real_f ((zip (map Left valargs) (map CoreUtils.exprType valargs)) ++ [(Right argexpr, startType)])
979 -- Return the conditional generate part
980 let gensm = AST.GenerateSm cond_label cond_scheme [] (if iter then
988 let res_type = (tfvec_elem . Var.varType) res
989 let cond_label = mkVHDLExtId "othercell"
990 -- if n > 0 or n < len-1
991 let cond_scheme = AST.IfGn $ n_cur AST.:/=: (AST.PrimLit "0")
992 -- Output to tmp[current n]
993 let resname = mkIndexedName tmp_name n_cur
994 -- Input from tmp[previous n]
995 let argexpr = vhdlNameToVHDLExpr $ mkIndexedName tmp_name n_prev
996 let (CoreSyn.Var real_f, already_mapped_args) = CoreSyn.collectArgs app_f
997 let valargs = get_val_args (Var.varType real_f) already_mapped_args
998 (app_concsms, used) <- genApplication (Right resname, res_type) real_f ((zip (map Left valargs) (map CoreUtils.exprType valargs)) ++ [(Right argexpr, res_type)])
999 -- Return the conditional generate part
1000 return (AST.GenerateSm cond_label cond_scheme [] app_concsms, used)
1002 genBlockRAM :: BuiltinBuilder
1003 genBlockRAM = genNoInsts $ genExprArgs genBlockRAM'
1005 genBlockRAM' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [(AST.Expr,Type.Type)] -> TranslatorSession [AST.ConcSm]
1006 genBlockRAM' (Left res) f args@[data_in,rdaddr,wraddr,wrenable] = do
1008 let (tup,data_out) = Type.splitAppTy (Var.varType res)
1009 let (tup',ramvec) = Type.splitAppTy tup
1010 let Just realram = Type.coreView ramvec
1011 let Just (tycon, types) = Type.splitTyConApp_maybe realram
1012 Just ram_vhdl_ty <- MonadState.lift tsType $ vhdlTy "wtf" (head types)
1013 -- Make the intermediate vector
1014 let ram_dec = AST.BDISD $ AST.SigDec ram_id ram_vhdl_ty Nothing
1015 -- Get the data_out name
1016 -- reslabels <- MonadState.lift tsType $ getFieldLabels (Var.varType res)
1017 let resname = varToVHDLName res
1018 -- let resname = mkSelectedName resname' (reslabels!!0)
1019 let rdaddr_int = genExprFCall (mkVHDLBasicId toIntegerId) $ fst rdaddr
1020 let argexpr = vhdlNameToVHDLExpr $ mkIndexedName (AST.NSimple ram_id) rdaddr_int
1021 let assign = mkUncondAssign (Right resname) argexpr
1022 let block_label = mkVHDLExtId ("blockRAM" ++ (varToString res))
1023 let block = AST.BlockSm block_label [] (AST.PMapAspect []) [ram_dec] [assign, mkUpdateProcSm]
1024 return [AST.CSBSm block]
1026 ram_id = mkVHDLBasicId "ram"
1027 mkUpdateProcSm :: AST.ConcSm
1028 mkUpdateProcSm = AST.CSPSm $ AST.ProcSm proclabel [clockId] [statement]
1030 proclabel = mkVHDLBasicId "updateRAM"
1031 rising_edge = mkVHDLBasicId "rising_edge"
1032 wraddr_int = genExprFCall (mkVHDLBasicId toIntegerId) $ fst wraddr
1033 ramloc = mkIndexedName (AST.NSimple ram_id) wraddr_int
1034 wform = AST.Wform [AST.WformElem (fst data_in) Nothing]
1035 ramassign = AST.SigAssign ramloc wform
1036 rising_edge_clk = genExprFCall rising_edge (AST.PrimName $ AST.NSimple clockId)
1037 statement = AST.IfSm (AST.And rising_edge_clk $ fst wrenable) [ramassign] [] Nothing
1039 genSplit :: BuiltinBuilder
1040 genSplit = genNoInsts genSplit'
1042 genSplit' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [(Either CoreSyn.CoreExpr AST.Expr, Type.Type)] -> TranslatorSession [AST.ConcSm]
1043 genSplit' (Left res) f args@[(vecIn,vecInType)] = do {
1044 ; len <- MonadState.lift tsType $ tfp_to_int $ tfvec_len_ty vecInType
1045 ; res_htype <- MonadState.lift tsType $ mkHType "\nGenerate.genSplit': Invalid result type" (Var.varType res)
1046 ; [argExpr] <- argsToVHDLExprs [vecIn]
1048 ; labels = getFieldLabels res_htype 0
1049 ; block_label = mkVHDLExtId ("split" ++ show argExpr)
1050 ; halflen = round ((fromIntegral len) / 2)
1051 ; rangeL = vecSlice (AST.PrimLit "0") (AST.PrimLit $ show (halflen - 1))
1052 ; rangeR = vecSlice (AST.PrimLit $ show halflen) (AST.PrimLit $ show (len - 1))
1053 ; resname = varToVHDLName res
1054 ; resnameL = mkSelectedName resname (labels!!0)
1055 ; resnameR = mkSelectedName resname (labels!!1)
1056 ; argexprL = vhdlNameToVHDLExpr rangeL
1057 ; argexprR = vhdlNameToVHDLExpr rangeR
1058 ; out_assignL = mkUncondAssign (Right resnameL) argexprL
1059 ; out_assignR = mkUncondAssign (Right resnameR) argexprR
1060 ; block = AST.BlockSm block_label [] (AST.PMapAspect []) [] [out_assignL, out_assignR]
1062 ; return [AST.CSBSm block]
1065 vecSlice init last = AST.NSlice (AST.SliceName (varToVHDLName res)
1066 (AST.ToRange init last))
1068 genSll :: BuiltinBuilder
1069 genSll = genNoInsts $ genExprArgs $ genExprRes genSll'
1070 genSll' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [(AST.Expr, Type.Type)] -> TranslatorSession AST.Expr
1071 genSll' res f [(arg1,_),(arg2,_)] = do {
1072 ; return $ (AST.Sll arg1 (genExprFCall (mkVHDLBasicId toIntegerId) arg2))
1075 genSra :: BuiltinBuilder
1076 genSra = genNoInsts $ genExprArgs $ genExprRes genSra'
1077 genSra' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [(AST.Expr, Type.Type)] -> TranslatorSession AST.Expr
1078 genSra' res f [(arg1,_),(arg2,_)] = do {
1079 ; return $ (AST.Sra arg1 (genExprFCall (mkVHDLBasicId toIntegerId) arg2))
1082 -----------------------------------------------------------------------------
1083 -- Function to generate VHDL for applications
1084 -----------------------------------------------------------------------------
1086 (Either CoreSyn.CoreBndr AST.VHDLName, Type.Type) -- ^ Where to store the result?
1087 -> CoreSyn.CoreBndr -- ^ The function to apply
1088 -> [(Either CoreSyn.CoreExpr AST.Expr, Type.Type)] -- ^ The arguments to apply
1089 -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
1090 -- ^ The corresponding VHDL concurrent statements and entities
1092 genApplication (dst, dsttype) f args = do
1093 nonemptydst <- case dst of
1094 Left bndr -> hasNonEmptyType bndr
1095 Right _ -> return True
1098 if Var.isGlobalId f then
1099 case Var.idDetails f of
1100 IdInfo.DataConWorkId dc -> do -- case dst of
1101 -- It's a datacon. Create a record from its arguments.
1103 -- We have the bndr, so we can get at the type
1104 htype_either <- MonadState.lift tsType $ mkHTypeEither dsttype
1105 let argsNoState = filter (\x -> not (either hasStateType (\x -> False) x)) (map fst args)
1106 let dcs = datacons_for dsttype
1107 case (dcs, argsNoState) of
1108 -- This is a type with a single datacon and a single
1109 -- argument, so no record is created (the type of the
1110 -- binder becomes the type of the single argument).
1112 [arg'] <- argsToVHDLExprs [arg]
1113 return ([mkUncondAssign dst arg'], [])
1114 -- In all other cases, a record type is created.
1115 _ -> case htype_either of
1116 Right htype@(AggrType _ _ _) -> do
1117 let dc_i = datacon_index dsttype dc
1118 let labels = getFieldLabels htype dc_i
1119 arg_exprs <- argsToVHDLExprs argsNoState
1120 let (final_labels, final_exprs) = case getConstructorFieldLabel htype of
1121 -- Only a single constructor
1124 -- Multiple constructors, so assign the
1125 -- constructor used to the constructor field as
1128 let dc_expr = AST.PrimName $ AST.NSimple $ mkVHDLExtId $ varToString f in
1129 (dc_label:labels, dc_expr:arg_exprs)
1130 return (zipWith mkassign final_labels final_exprs, [])
1132 mkassign :: AST.VHDLId -> AST.Expr -> AST.ConcSm
1133 mkassign label arg =
1134 let sel_name = mkSelectedName ((either varToVHDLName id) dst) label in
1135 mkUncondAssign (Right sel_name) arg
1136 -- Enumeration types have no arguments and are just
1137 -- simple assignments
1138 Right (EnumType _ _) ->
1140 -- These builtin types are also enumeration types
1141 Right (BuiltinType tyname) | tyname `elem` ["Bit", "Bool"] ->
1143 Right _ -> error $ "Datacon application does not result in a aggregate type? datacon: " ++ pprString f ++ " Args: " ++ show args
1144 Left _ -> error $ "Unrepresentable result type in datacon application? datacon: " ++ pprString f ++ " Args: " ++ show args
1146 -- Simple uncoditional assignment, for (built-in)
1147 -- enumeration types
1149 expr <- MonadState.lift tsType $ dataconToVHDLExpr dc
1150 return ([mkUncondAssign dst expr], [])
1153 -- let dcs = datacons_for dsttype
1154 -- error $ "\nGenerate.genApplication(DataConWorkId): Can't generate dataconstructor application without an original binder" ++ show dcs
1155 IdInfo.DataConWrapId dc -> case dst of
1156 -- It's a datacon. Create a record from its arguments.
1158 case (Map.lookup (varToString f) globalNameTable) of
1159 Just (arg_count, builder) ->
1160 if length args == arg_count then
1163 error $ "\nGenerate.genApplication(DataConWrapId): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args
1164 Nothing -> error $ "\nGenerate.genApplication(DataConWrapId): Can't generate dataconwrapper: " ++ (show dc)
1165 Right _ -> error "\nGenerate.genApplication(DataConWrapId): Can't generate dataconwrapper application without an original binder"
1167 -- It's a global value imported from elsewhere. These can be builtin
1168 -- functions. Look up the function name in the name table and execute
1169 -- the associated builder if there is any and the argument count matches
1170 -- (this should always be the case if it typechecks, but just to be
1172 case (Map.lookup (varToString f) globalNameTable) of
1173 Just (arg_count, builder) ->
1174 if length args == arg_count then
1177 error $ "\nGenerate.genApplication(VanillaId): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args
1179 top <- isTopLevelBinder f
1182 -- Local binder that references a top level binding. Generate a
1183 -- component instantiation.
1184 signature <- getEntity f
1185 args' <- argsToVHDLExprs (map fst args)
1186 let entity_id = ent_id signature
1187 -- TODO: Using show here isn't really pretty, but we'll need some
1188 -- unique-ish value...
1189 let label = "comp_ins_" ++ (either show prettyShow) dst
1190 let portmaps = mkAssocElems args' ((either varToVHDLName id) dst) signature
1191 return ([mkComponentInst label entity_id portmaps], [f])
1193 -- Not a top level binder, so this must be a local variable reference.
1194 -- It should have a representable type (and thus, no arguments) and a
1195 -- signal should be generated for it. Just generate an unconditional
1197 -- FIXME : I DONT KNOW IF THE ABOVE COMMENT HOLDS HERE, SO FOR NOW JUST ERROR!
1198 -- f' <- MonadState.lift tsType $ varToVHDLExpr f
1199 -- return $ ([mkUncondAssign dst f'], [])
1200 do errtype <- case dst of
1202 htype <- MonadState.lift tsType $ mkHTypeEither (Var.varType bndr)
1204 Right vhd -> return $ show vhd
1205 error ("\nGenerate.genApplication(VanillaId): Using function from another module that is not a known builtin: " ++ (pprString f) ++ "::" ++ errtype)
1206 IdInfo.ClassOpId cls ->
1207 -- FIXME: Not looking for what instance this class op is called for
1208 -- Is quite stupid of course.
1209 case (Map.lookup (varToString f) globalNameTable) of
1210 Just (arg_count, builder) ->
1211 if length args == arg_count then
1214 error $ "\nGenerate.genApplication(ClassOpId): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args
1215 Nothing -> error $ "\nGenerate.genApplication(ClassOpId): Using function from another module that is not a known builtin: " ++ pprString f
1216 details -> error $ "\nGenerate.genApplication: Calling unsupported function " ++ pprString f ++ " with GlobalIdDetails " ++ pprString details
1218 top <- isTopLevelBinder f
1221 -- Local binder that references a top level binding. Generate a
1222 -- component instantiation.
1223 signature <- getEntity f
1224 args' <- argsToVHDLExprs (map fst args)
1225 let entity_id = ent_id signature
1226 -- TODO: Using show here isn't really pretty, but we'll need some
1227 -- unique-ish value...
1228 let label = "comp_ins_" ++ (either (prettyShow . varToVHDLName) prettyShow) dst
1229 let portmaps = mkAssocElems args' ((either varToVHDLName id) dst) signature
1230 return ([mkComponentInst label entity_id portmaps], [f])
1232 -- Not a top level binder, so this must be a local variable reference.
1233 -- It should have a representable type (and thus, no arguments) and a
1234 -- signal should be generated for it. Just generate an unconditional
1236 do f' <- MonadState.lift tsType $ varToVHDLExpr f
1237 return ([mkUncondAssign dst f'], [])
1238 else -- Destination has empty type, don't generate anything
1240 -----------------------------------------------------------------------------
1241 -- Functions to generate functions dealing with vectors.
1242 -----------------------------------------------------------------------------
1244 -- Returns the VHDLId of the vector function with the given name for the given
1245 -- element type. Generates -- this function if needed.
1246 vectorFunId :: Type.Type -> String -> TypeSession AST.VHDLId
1247 vectorFunId el_ty fname = do
1248 let error_msg = "\nGenerate.vectorFunId: Can not construct vector function for element: " ++ pprString el_ty
1249 -- TODO: Handle the Nothing case?
1250 elemTM_maybe <- vhdlTy error_msg el_ty
1251 let elemTM = Maybe.fromMaybe
1252 (error $ "\nGenerate.vectorFunId: Cannot generate vector function \"" ++ fname ++ "\" for the empty type \"" ++ (pprString el_ty) ++ "\"")
1254 -- TODO: This should not be duplicated from mk_vector_ty. Probably but it in
1255 -- the VHDLState or something.
1256 let vectorTM = mkVHDLExtId $ "vector_" ++ (AST.fromVHDLId elemTM)
1257 typefuns <- MonadState.get tsTypeFuns
1258 el_htype <- mkHType error_msg el_ty
1259 case Map.lookup (UVecType el_htype, fname) typefuns of
1260 -- Function already generated, just return it
1261 Just (id, _) -> return id
1262 -- Function not generated yet, generate it
1264 let functions = genUnconsVectorFuns elemTM vectorTM
1265 case lookup fname functions of
1267 MonadState.modify tsTypeFuns $ Map.insert (UVecType el_htype, fname) (function_id, (fst body))
1268 mapM_ (vectorFunId el_ty) (snd body)
1270 Nothing -> error $ "\nGenerate.vectorFunId: I don't know how to generate vector function " ++ fname
1272 function_id = mkVHDLExtId fname
1274 genUnconsVectorFuns :: AST.TypeMark -- ^ type of the vector elements
1275 -> AST.TypeMark -- ^ type of the vector
1276 -> [(String, (AST.SubProgBody, [String]))]
1277 genUnconsVectorFuns elemTM vectorTM =
1278 [ (exId, (AST.SubProgBody exSpec [] [exExpr],[]))
1279 , (replaceId, (AST.SubProgBody replaceSpec [AST.SPVD replaceVar] [replaceExpr1,replaceExpr2,replaceRet],[]))
1280 , (lastId, (AST.SubProgBody lastSpec [] [lastExpr],[]))
1281 , (initId, (AST.SubProgBody initSpec [AST.SPVD initVar] [initExpr, initRet],[]))
1282 , (minimumId, (AST.SubProgBody minimumSpec [] [minimumExpr],[]))
1283 , (takeId, (AST.SubProgBody takeSpec [AST.SPVD takeVar] [takeExpr, takeRet],[minimumId]))
1284 , (dropId, (AST.SubProgBody dropSpec [AST.SPVD dropVar] [dropExpr, dropRet],[]))
1285 , (plusgtId, (AST.SubProgBody plusgtSpec [AST.SPVD plusgtVar] [plusgtExpr, plusgtRet],[]))
1286 , (emptyId, (AST.SubProgBody emptySpec [AST.SPVD emptyVar] [emptyExpr],[]))
1287 , (singletonId, (AST.SubProgBody singletonSpec [AST.SPVD singletonVar] [singletonRet],[]))
1288 , (copynId, (AST.SubProgBody copynSpec [AST.SPVD copynVar] [copynExpr],[]))
1289 , (selId, (AST.SubProgBody selSpec [AST.SPVD selVar] [selFor, selRet],[]))
1290 , (ltplusId, (AST.SubProgBody ltplusSpec [AST.SPVD ltplusVar] [ltplusExpr, ltplusRet],[]))
1291 , (plusplusId, (AST.SubProgBody plusplusSpec [AST.SPVD plusplusVar] [plusplusExpr, plusplusRet],[]))
1292 , (lengthTId, (AST.SubProgBody lengthTSpec [] [lengthTExpr],[]))
1293 , (shiftIntoLId, (AST.SubProgBody shiftlSpec [AST.SPVD shiftlVar] [shiftlExpr, shiftlRet], [initId]))
1294 , (shiftIntoRId, (AST.SubProgBody shiftrSpec [AST.SPVD shiftrVar] [shiftrExpr, shiftrRet], [tailId]))
1295 , (nullId, (AST.SubProgBody nullSpec [] [nullExpr], []))
1296 , (rotlId, (AST.SubProgBody rotlSpec [AST.SPVD rotlVar] [rotlExpr, rotlRet], [nullId, lastId, initId]))
1297 , (rotrId, (AST.SubProgBody rotrSpec [AST.SPVD rotrVar] [rotrExpr, rotrRet], [nullId, tailId, headId]))
1298 , (reverseId, (AST.SubProgBody reverseSpec [AST.SPVD reverseVar] [reverseFor, reverseRet], []))
1301 ixPar = AST.unsafeVHDLBasicId "ix"
1302 vecPar = AST.unsafeVHDLBasicId "vec"
1303 vec1Par = AST.unsafeVHDLBasicId "vec1"
1304 vec2Par = AST.unsafeVHDLBasicId "vec2"
1305 nPar = AST.unsafeVHDLBasicId "n"
1306 leftPar = AST.unsafeVHDLBasicId "nLeft"
1307 rightPar = AST.unsafeVHDLBasicId "nRight"
1308 iId = AST.unsafeVHDLBasicId "i"
1310 aPar = AST.unsafeVHDLBasicId "a"
1311 fPar = AST.unsafeVHDLBasicId "f"
1312 sPar = AST.unsafeVHDLBasicId "s"
1313 resId = AST.unsafeVHDLBasicId "res"
1314 exSpec = AST.Function (mkVHDLExtId exId) [AST.IfaceVarDec vecPar vectorTM,
1315 AST.IfaceVarDec ixPar unsignedTM] elemTM
1316 exExpr = AST.ReturnSm (Just $ AST.PrimName $ AST.NIndexed
1317 (AST.IndexedName (AST.NSimple vecPar) [genExprFCall (mkVHDLBasicId toIntegerId) (AST.PrimName $ AST.NSimple ixPar)]))
1318 replaceSpec = AST.Function (mkVHDLExtId replaceId) [ AST.IfaceVarDec vecPar vectorTM
1319 , AST.IfaceVarDec iPar unsignedTM
1320 , AST.IfaceVarDec aPar elemTM
1322 -- variable res : fsvec_x (0 to vec'length-1);
1325 (AST.SubtypeIn vectorTM
1326 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1327 [AST.ToRange (AST.PrimLit "0")
1328 (AST.PrimName (AST.NAttribute $
1329 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1330 (AST.PrimLit "1")) ]))
1332 -- res AST.:= vec(0 to i-1) & a & vec(i+1 to length'vec-1)
1333 replaceExpr1 = AST.NSimple resId AST.:= AST.PrimName (AST.NSimple vecPar)
1334 replaceExpr2 = AST.NIndexed (AST.IndexedName (AST.NSimple resId) [genExprFCall (mkVHDLBasicId toIntegerId) (AST.PrimName $ AST.NSimple iPar)]) AST.:= AST.PrimName (AST.NSimple aPar)
1335 replaceRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1336 vecSlice init last = AST.PrimName (AST.NSlice
1338 (AST.NSimple vecPar)
1339 (AST.ToRange init last)))
1340 lastSpec = AST.Function (mkVHDLExtId lastId) [AST.IfaceVarDec vecPar vectorTM] elemTM
1341 -- return vec(vec'length-1);
1342 lastExpr = AST.ReturnSm (Just (AST.PrimName $ AST.NIndexed (AST.IndexedName
1343 (AST.NSimple vecPar)
1344 [AST.PrimName (AST.NAttribute $
1345 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing)
1346 AST.:-: AST.PrimLit "1"])))
1347 initSpec = AST.Function (mkVHDLExtId initId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
1348 -- variable res : fsvec_x (0 to vec'length-2);
1351 (AST.SubtypeIn vectorTM
1352 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1353 [AST.ToRange (AST.PrimLit "0")
1354 (AST.PrimName (AST.NAttribute $
1355 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1356 (AST.PrimLit "2")) ]))
1358 -- resAST.:= vec(0 to vec'length-2)
1359 initExpr = AST.NSimple resId AST.:= (vecSlice
1361 (AST.PrimName (AST.NAttribute $
1362 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing)
1363 AST.:-: AST.PrimLit "2"))
1364 initRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1365 minimumSpec = AST.Function (mkVHDLExtId minimumId) [AST.IfaceVarDec leftPar naturalTM,
1366 AST.IfaceVarDec rightPar naturalTM ] naturalTM
1367 minimumExpr = AST.IfSm ((AST.PrimName $ AST.NSimple leftPar) AST.:<: (AST.PrimName $ AST.NSimple rightPar))
1368 [AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple leftPar)]
1370 (Just $ AST.Else [minimumExprRet])
1371 where minimumExprRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple rightPar)
1372 takeSpec = AST.Function (mkVHDLExtId takeId) [AST.IfaceVarDec nPar naturalTM,
1373 AST.IfaceVarDec vecPar vectorTM ] vectorTM
1374 -- variable res : fsvec_x (0 to (minimum (n,vec'length))-1);
1375 minLength = AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId minimumId))
1376 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple nPar)
1377 ,Nothing AST.:=>: AST.ADExpr (AST.PrimName (AST.NAttribute $
1378 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))]
1381 (AST.SubtypeIn vectorTM
1382 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1383 [AST.ToRange (AST.PrimLit "0")
1385 (AST.PrimLit "1")) ]))
1387 -- res AST.:= vec(0 to n-1)
1388 takeExpr = AST.NSimple resId AST.:=
1389 (vecSlice (AST.PrimLit "0")
1390 (minLength AST.:-: AST.PrimLit "1"))
1391 takeRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1392 dropSpec = AST.Function (mkVHDLExtId dropId) [AST.IfaceVarDec nPar naturalTM,
1393 AST.IfaceVarDec vecPar vectorTM ] vectorTM
1394 -- variable res : fsvec_x (0 to vec'length-n-1);
1397 (AST.SubtypeIn vectorTM
1398 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1399 [AST.ToRange (AST.PrimLit "0")
1400 (AST.PrimName (AST.NAttribute $
1401 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1402 (AST.PrimName $ AST.NSimple nPar)AST.:-: (AST.PrimLit "1")) ]))
1404 -- res AST.:= vec(n to vec'length-1)
1405 dropExpr = AST.NSimple resId AST.:= (vecSlice
1406 (AST.PrimName $ AST.NSimple nPar)
1407 (AST.PrimName (AST.NAttribute $
1408 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing)
1409 AST.:-: AST.PrimLit "1"))
1410 dropRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1411 plusgtSpec = AST.Function (mkVHDLExtId plusgtId) [AST.IfaceVarDec aPar elemTM,
1412 AST.IfaceVarDec vecPar vectorTM] vectorTM
1413 -- variable res : fsvec_x (0 to vec'length);
1416 (AST.SubtypeIn vectorTM
1417 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1418 [AST.ToRange (AST.PrimLit "0")
1419 (AST.PrimName (AST.NAttribute $
1420 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))]))
1422 plusgtExpr = AST.NSimple resId AST.:=
1423 ((AST.PrimName $ AST.NSimple aPar) AST.:&:
1424 (AST.PrimName $ AST.NSimple vecPar))
1425 plusgtRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1426 emptySpec = AST.Function (mkVHDLExtId emptyId) [] vectorTM
1429 (AST.SubtypeIn vectorTM
1430 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1431 [AST.ToRange (AST.PrimLit "0") (AST.PrimLit "-1")]))
1433 emptyExpr = AST.ReturnSm (Just $ AST.PrimName (AST.NSimple resId))
1434 singletonSpec = AST.Function (mkVHDLExtId singletonId) [AST.IfaceVarDec aPar elemTM ]
1436 -- variable res : fsvec_x (0 to 0) := (others => a);
1439 (AST.SubtypeIn vectorTM
1440 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1441 [AST.ToRange (AST.PrimLit "0") (AST.PrimLit "0")]))
1442 (Just $ AST.Aggregate [AST.ElemAssoc (Just AST.Others)
1443 (AST.PrimName $ AST.NSimple aPar)])
1444 singletonRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1445 copynSpec = AST.Function (mkVHDLExtId copynId) [AST.IfaceVarDec nPar naturalTM,
1446 AST.IfaceVarDec aPar elemTM ] vectorTM
1447 -- variable res : fsvec_x (0 to n-1) := (others => a);
1450 (AST.SubtypeIn vectorTM
1451 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1452 [AST.ToRange (AST.PrimLit "0")
1453 ((AST.PrimName (AST.NSimple nPar)) AST.:-:
1454 (AST.PrimLit "1")) ]))
1455 (Just $ AST.Aggregate [AST.ElemAssoc (Just AST.Others)
1456 (AST.PrimName $ AST.NSimple aPar)])
1458 copynExpr = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1459 selSpec = AST.Function (mkVHDLExtId selId) [AST.IfaceVarDec fPar naturalTM,
1460 AST.IfaceVarDec sPar naturalTM,
1461 AST.IfaceVarDec nPar naturalTM,
1462 AST.IfaceVarDec vecPar vectorTM ] vectorTM
1463 -- variable res : fsvec_x (0 to n-1);
1466 (AST.SubtypeIn vectorTM
1467 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1468 [AST.ToRange (AST.PrimLit "0")
1469 ((AST.PrimName (AST.NSimple nPar)) AST.:-:
1470 (AST.PrimLit "1")) ])
1473 -- for i res'range loop
1474 -- res(i) := vec(f+i*s);
1476 selFor = AST.ForSM iId (AST.AttribRange $ AST.AttribName (AST.NSimple resId) (AST.NSimple rangeId) Nothing) [selAssign]
1477 -- res(i) := vec(f+i*s);
1478 selAssign = let origExp = AST.PrimName (AST.NSimple fPar) AST.:+:
1479 (AST.PrimName (AST.NSimple iId) AST.:*:
1480 AST.PrimName (AST.NSimple sPar)) in
1481 AST.NIndexed (AST.IndexedName (AST.NSimple resId) [AST.PrimName (AST.NSimple iId)]) AST.:=
1482 (AST.PrimName $ AST.NIndexed (AST.IndexedName (AST.NSimple vecPar) [origExp]))
1484 selRet = AST.ReturnSm (Just $ AST.PrimName (AST.NSimple resId))
1485 ltplusSpec = AST.Function (mkVHDLExtId ltplusId) [AST.IfaceVarDec vecPar vectorTM,
1486 AST.IfaceVarDec aPar elemTM] vectorTM
1487 -- variable res : fsvec_x (0 to vec'length);
1490 (AST.SubtypeIn vectorTM
1491 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1492 [AST.ToRange (AST.PrimLit "0")
1493 (AST.PrimName (AST.NAttribute $
1494 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))]))
1496 ltplusExpr = AST.NSimple resId AST.:=
1497 ((AST.PrimName $ AST.NSimple vecPar) AST.:&:
1498 (AST.PrimName $ AST.NSimple aPar))
1499 ltplusRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1500 plusplusSpec = AST.Function (mkVHDLExtId plusplusId) [AST.IfaceVarDec vec1Par vectorTM,
1501 AST.IfaceVarDec vec2Par vectorTM]
1503 -- variable res : fsvec_x (0 to vec1'length + vec2'length -1);
1506 (AST.SubtypeIn vectorTM
1507 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1508 [AST.ToRange (AST.PrimLit "0")
1509 (AST.PrimName (AST.NAttribute $
1510 AST.AttribName (AST.NSimple vec1Par) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:+:
1511 AST.PrimName (AST.NAttribute $
1512 AST.AttribName (AST.NSimple vec2Par) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1515 plusplusExpr = AST.NSimple resId AST.:=
1516 ((AST.PrimName $ AST.NSimple vec1Par) AST.:&:
1517 (AST.PrimName $ AST.NSimple vec2Par))
1518 plusplusRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1519 lengthTSpec = AST.Function (mkVHDLExtId lengthTId) [AST.IfaceVarDec vecPar vectorTM] naturalTM
1520 lengthTExpr = AST.ReturnSm (Just $ AST.PrimName (AST.NAttribute $
1521 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))
1522 shiftlSpec = AST.Function (mkVHDLExtId shiftIntoLId) [AST.IfaceVarDec vecPar vectorTM,
1523 AST.IfaceVarDec aPar elemTM ] vectorTM
1524 -- variable res : fsvec_x (0 to vec'length-1);
1527 (AST.SubtypeIn vectorTM
1528 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1529 [AST.ToRange (AST.PrimLit "0")
1530 (AST.PrimName (AST.NAttribute $
1531 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1532 (AST.PrimLit "1")) ]))
1534 -- res := a & init(vec)
1535 shiftlExpr = AST.NSimple resId AST.:=
1536 (AST.PrimName (AST.NSimple aPar) AST.:&:
1537 (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId initId))
1538 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]))
1539 shiftlRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1540 shiftrSpec = AST.Function (mkVHDLExtId shiftIntoRId) [AST.IfaceVarDec vecPar vectorTM,
1541 AST.IfaceVarDec aPar elemTM ] vectorTM
1542 -- variable res : fsvec_x (0 to vec'length-1);
1545 (AST.SubtypeIn vectorTM
1546 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1547 [AST.ToRange (AST.PrimLit "0")
1548 (AST.PrimName (AST.NAttribute $
1549 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1550 (AST.PrimLit "1")) ]))
1552 -- res := tail(vec) & a
1553 shiftrExpr = AST.NSimple resId AST.:=
1554 ((AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId tailId))
1555 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]) AST.:&:
1556 (AST.PrimName (AST.NSimple aPar)))
1558 shiftrRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1559 nullSpec = AST.Function (mkVHDLExtId nullId) [AST.IfaceVarDec vecPar vectorTM] booleanTM
1560 -- return vec'length = 0
1561 nullExpr = AST.ReturnSm (Just $
1562 AST.PrimName (AST.NAttribute $
1563 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:=:
1565 rotlSpec = AST.Function (mkVHDLExtId rotlId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
1566 -- variable res : fsvec_x (0 to vec'length-1);
1569 (AST.SubtypeIn vectorTM
1570 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1571 [AST.ToRange (AST.PrimLit "0")
1572 (AST.PrimName (AST.NAttribute $
1573 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1574 (AST.PrimLit "1")) ]))
1576 -- if null(vec) then res := vec else res := last(vec) & init(vec)
1577 rotlExpr = AST.IfSm (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId nullId))
1578 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)])
1579 [AST.NSimple resId AST.:= (AST.PrimName $ AST.NSimple vecPar)]
1581 (Just $ AST.Else [rotlExprRet])
1583 AST.NSimple resId AST.:=
1584 ((AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId lastId))
1585 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]) AST.:&:
1586 (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId initId))
1587 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]))
1588 rotlRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1589 rotrSpec = AST.Function (mkVHDLExtId rotrId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
1590 -- variable res : fsvec_x (0 to vec'length-1);
1593 (AST.SubtypeIn vectorTM
1594 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1595 [AST.ToRange (AST.PrimLit "0")
1596 (AST.PrimName (AST.NAttribute $
1597 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1598 (AST.PrimLit "1")) ]))
1600 -- if null(vec) then res := vec else res := tail(vec) & head(vec)
1601 rotrExpr = AST.IfSm (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId nullId))
1602 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)])
1603 [AST.NSimple resId AST.:= (AST.PrimName $ AST.NSimple vecPar)]
1605 (Just $ AST.Else [rotrExprRet])
1607 AST.NSimple resId AST.:=
1608 ((AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId tailId))
1609 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]) AST.:&:
1610 (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId headId))
1611 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]))
1612 rotrRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1613 reverseSpec = AST.Function (mkVHDLExtId reverseId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
1616 (AST.SubtypeIn vectorTM
1617 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1618 [AST.ToRange (AST.PrimLit "0")
1619 (AST.PrimName (AST.NAttribute $
1620 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1621 (AST.PrimLit "1")) ]))
1623 -- for i in 0 to res'range loop
1624 -- res(vec'length-i-1) := vec(i);
1627 AST.ForSM iId (AST.AttribRange $ AST.AttribName (AST.NSimple resId) (AST.NSimple rangeId) Nothing) [reverseAssign]
1628 -- res(vec'length-i-1) := vec(i);
1629 reverseAssign = AST.NIndexed (AST.IndexedName (AST.NSimple resId) [destExp]) AST.:=
1630 (AST.PrimName $ AST.NIndexed (AST.IndexedName (AST.NSimple vecPar)
1631 [AST.PrimName $ AST.NSimple iId]))
1632 where destExp = AST.PrimName (AST.NAttribute $ AST.AttribName (AST.NSimple vecPar)
1633 (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1634 AST.PrimName (AST.NSimple iId) AST.:-:
1637 reverseRet = AST.ReturnSm (Just $ AST.PrimName (AST.NSimple resId))
1640 -----------------------------------------------------------------------------
1641 -- A table of builtin functions
1642 -----------------------------------------------------------------------------
1644 -- A function that generates VHDL for a builtin function
1645 type BuiltinBuilder =
1646 (Either CoreSyn.CoreBndr AST.VHDLName) -- ^ The destination signal and it's original type
1647 -> CoreSyn.CoreBndr -- ^ The function called
1648 -> [(Either CoreSyn.CoreExpr AST.Expr, Type.Type)] -- ^ The value arguments passed (excluding type and
1649 -- dictionary arguments).
1650 -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
1651 -- ^ The corresponding VHDL concurrent statements and entities
1654 -- A map of a builtin function to VHDL function builder
1655 type NameTable = Map.Map String (Int, BuiltinBuilder )
1657 -- | The builtin functions we support. Maps a name to an argument count and a
1658 -- builder function. If you add a name to this map, don't forget to add
1659 -- it to VHDL.Constants/builtinIds as well.
1660 globalNameTable :: NameTable
1661 globalNameTable = Map.fromList
1662 [ (exId , (2, genFCall True ) )
1663 , (replaceId , (3, genFCall False ) )
1664 , (headId , (1, genFCall True ) )
1665 , (lastId , (1, genFCall True ) )
1666 , (tailId , (1, genFCall False ) )
1667 , (initId , (1, genFCall False ) )
1668 , (takeId , (2, genFCall False ) )
1669 , (dropId , (2, genFCall False ) )
1670 , (selId , (4, genFCall False ) )
1671 , (plusgtId , (2, genFCall False ) )
1672 , (ltplusId , (2, genFCall False ) )
1673 , (plusplusId , (2, genFCall False ) )
1674 , (mapId , (2, genMap ) )
1675 , (zipWithId , (3, genZipWith ) )
1676 , (foldlId , (3, genFoldl ) )
1677 , (foldrId , (3, genFoldr ) )
1678 , (zipId , (2, genZip ) )
1679 , (unzipId , (1, genUnzip ) )
1680 , (shiftIntoLId , (2, genFCall False ) )
1681 , (shiftIntoRId , (2, genFCall False ) )
1682 , (rotlId , (1, genFCall False ) )
1683 , (rotrId , (1, genFCall False ) )
1684 , (concatId , (1, genConcat ) )
1685 , (reverseId , (1, genFCall False ) )
1686 , (iteratenId , (3, genIteraten ) )
1687 , (iterateId , (2, genIterate ) )
1688 , (generatenId , (3, genGeneraten ) )
1689 , (generateId , (2, genGenerate ) )
1690 , (emptyId , (0, genFCall False ) )
1691 , (singletonId , (1, genFCall False ) )
1692 , (copynId , (2, genFCall False ) )
1693 , (copyId , (1, genCopy ) )
1694 , (lengthTId , (1, genFCall False ) )
1695 , (nullId , (1, genFCall False ) )
1696 , (hwxorId , (2, genOperator2 AST.Xor ) )
1697 , (hwandId , (2, genOperator2 AST.And ) )
1698 , (hworId , (2, genOperator2 AST.Or ) )
1699 , (hwnotId , (1, genOperator1 AST.Not ) )
1700 , (equalityId , (2, genOperator2 (AST.:=:) ) )
1701 , (inEqualityId , (2, genOperator2 (AST.:/=:) ) )
1702 , (ltId , (2, genOperator2 (AST.:<:) ) )
1703 , (lteqId , (2, genOperator2 (AST.:<=:) ) )
1704 , (gtId , (2, genOperator2 (AST.:>:) ) )
1705 , (gteqId , (2, genOperator2 (AST.:>=:) ) )
1706 , (boolOrId , (2, genOperator2 AST.Or ) )
1707 , (boolAndId , (2, genOperator2 AST.And ) )
1708 , (boolNot , (1, genOperator1 AST.Not ) )
1709 , (plusId , (2, genOperator2 (AST.:+:) ) )
1710 , (timesId , (2, genTimes ) )
1711 , (negateId , (1, genNegation ) )
1712 , (minusId , (2, genOperator2 (AST.:-:) ) )
1713 , (fromSizedWordId , (1, genFromSizedWord ) )
1714 , (fromRangedWordId , (1, genFromRangedWord ) )
1715 , (fromIntegerId , (1, genFromInteger ) )
1716 , (resizeWordId , (1, genResize ) )
1717 , (resizeIntId , (1, genResize ) )
1718 , (sizedIntId , (1, genSizedInt ) )
1719 , (smallIntegerId , (1, genFromInteger ) )
1720 , (fstId , (1, genFst ) )
1721 , (sndId , (1, genSnd ) )
1722 , (blockRAMId , (5, genBlockRAM ) )
1723 , (splitId , (1, genSplit ) )
1724 , (xorId , (2, genOperator2 AST.Xor ) )
1725 , (shiftLId , (2, genSll ) )
1726 , (shiftRId , (2, genSra ) )
1727 --, (tfvecId , (1, genTFVec ) )
1728 , (minimumId , (2, error "\nFunction name: \"minimum\" is used internally, use another name"))