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 (AST.PrimLit . show) [0..(length enums)-1], 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 (AST.PrimLit . show) [0..(length enums)-1], 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 leftso that the expression related to the default case is the last
314 -- Does NOT apply when there is no DEFAULT case and there are no binders
315 let alts' = if ((any (\(_,x,_) -> not (null x)) alts) || ((\(x,_,_)->x) (head alts)) == CoreSyn.DEFAULT ) then
316 ((tail alts) ++ [head alts])
319 exprs <- MonadState.lift tsType $ mapM (varToVHDLExpr . (\(_,_,CoreSyn.Var expr) -> expr)) alts' --((tail alts) ++ [head alts])
320 return ([mkAltsAssign (Left bndr) cond_exprs exprs], [])
322 mkConcSm (_, CoreSyn.Case _ _ _ _) = error "\nVHDL.mkConcSm: Not in normal form: Case statement does not have a simple variable as scrutinee"
323 mkConcSm (bndr, expr) = error $ "\nVHDL.mkConcSM: Unsupported binding in let expression: " ++ pprString bndr ++ " = " ++ pprString expr
325 -----------------------------------------------------------------------------
326 -- Functions to generate VHDL for builtin functions
327 -----------------------------------------------------------------------------
329 -- | A function to wrap a builder-like function that expects its arguments to
331 genExprArgs wrap dst func args = do
332 args' <- argsToVHDLExprs (map fst args)
333 wrap dst func (zip args' (map snd args))
335 -- | Turn the all lefts into VHDL Expressions.
336 argsToVHDLExprs :: [Either CoreSyn.CoreExpr AST.Expr] -> TranslatorSession [AST.Expr]
337 argsToVHDLExprs = catMaybesM . (mapM argToVHDLExpr)
339 argToVHDLExpr :: Either CoreSyn.CoreExpr AST.Expr -> TranslatorSession (Maybe AST.Expr)
340 argToVHDLExpr (Left expr) = MonadState.lift tsType $ do
341 let errmsg = "Generate.argToVHDLExpr: Using non-representable type? Should not happen!"
342 ty_maybe <- vhdlTy errmsg expr
345 vhdl_expr <- varToVHDLExpr $ exprToVar expr
346 return $ Just vhdl_expr
347 Nothing -> return Nothing
349 argToVHDLExpr (Right expr) = return $ Just expr
351 -- A function to wrap a builder-like function that generates no component
354 (dst -> func -> args -> TranslatorSession [AST.ConcSm])
355 -> (dst -> func -> args -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr]))
356 genNoInsts wrap dst func args = do
357 concsms <- wrap dst func args
360 -- | A function to wrap a builder-like function that expects its arguments to
363 -- (dst -> func -> [Var.Var] -> res)
364 -- -> (dst -> func -> [Either CoreSyn.CoreExpr AST.Expr] -> res)
365 -- genVarArgs wrap = genCoreArgs $ \dst func args -> let
366 -- args' = map exprToVar args
368 -- wrap dst func args'
370 -- | A function to wrap a builder-like function that expects its arguments to
371 -- be core expressions.
373 (dst -> func -> [CoreSyn.CoreExpr] -> res)
374 -> (dst -> func -> [(Either CoreSyn.CoreExpr AST.Expr, Type.Type)] -> res)
375 genCoreArgs wrap dst func args = wrap dst func args'
377 -- Check (rather crudely) that all arguments are CoreExprs
378 args' = case Either.partitionEithers (map fst args) of
379 (exprargs, []) -> exprargs
380 (exprsargs, rest) -> error $ "\nGenerate.genCoreArgs: expect core expression arguments but found ast exprs:" ++ (show rest)
382 -- | A function to wrap a builder-like function that produces an expression
383 -- and expects it to be assigned to the destination.
385 ((Either CoreSyn.CoreBndr AST.VHDLName) -> func -> [arg] -> TranslatorSession AST.Expr)
386 -> ((Either CoreSyn.CoreBndr AST.VHDLName) -> func -> [arg] -> TranslatorSession [AST.ConcSm])
387 genExprRes wrap dst func args = do
388 expr <- wrap dst func args
389 return [mkUncondAssign dst expr]
391 -- | Generate a binary operator application. The first argument should be a
392 -- constructor from the AST.Expr type, e.g. AST.And.
393 genOperator2 :: (AST.Expr -> AST.Expr -> AST.Expr) -> BuiltinBuilder
394 genOperator2 op = genNoInsts $ genExprArgs $ genExprRes (genOperator2' op)
395 genOperator2' :: (AST.Expr -> AST.Expr -> AST.Expr) -> dst -> CoreSyn.CoreBndr -> [(AST.Expr, Type.Type)] -> TranslatorSession AST.Expr
396 genOperator2' op _ f [(arg1,_), (arg2,_)] = return $ op arg1 arg2
398 -- | Generate a unary operator application
399 genOperator1 :: (AST.Expr -> AST.Expr) -> BuiltinBuilder
400 genOperator1 op = genNoInsts $ genExprArgs $ genExprRes (genOperator1' op)
401 genOperator1' :: (AST.Expr -> AST.Expr) -> dst -> CoreSyn.CoreBndr -> [(AST.Expr, Type.Type)] -> TranslatorSession AST.Expr
402 genOperator1' op _ f [(arg,_)] = return $ op arg
404 -- | Generate a unary operator application
405 genNegation :: BuiltinBuilder
406 genNegation = genNoInsts $ genExprRes genNegation'
407 genNegation' :: dst -> CoreSyn.CoreBndr -> [(Either CoreSyn.CoreExpr AST.Expr, Type.Type)] -> TranslatorSession AST.Expr
408 genNegation' _ f [(arg,argType)] = do
409 [arg1] <- argsToVHDLExprs [arg]
410 let (tycon, args) = Type.splitTyConApp argType
411 let name = Name.getOccString (TyCon.tyConName tycon)
413 "Signed" -> return $ AST.Neg arg1
414 otherwise -> error $ "\nGenerate.genNegation': Negation not allowed for type: " ++ show name
416 -- | Generate a function call from the destination binder, function name and a
417 -- list of expressions (its arguments)
418 genFCall :: Bool -> BuiltinBuilder
419 genFCall switch = genNoInsts $ genExprArgs $ genExprRes (genFCall' switch)
420 genFCall' :: Bool -> Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [(AST.Expr, Type.Type)] -> TranslatorSession AST.Expr
421 genFCall' switch (Left res) f args = do
422 let fname = varToString f
423 let el_ty = if switch then (Var.varType res) else ((tfvec_elem . Var.varType) res)
424 id <- MonadState.lift tsType $ vectorFunId el_ty fname
425 return $ AST.PrimFCall $ AST.FCall (AST.NSimple id) $
426 map (\exp -> Nothing AST.:=>: AST.ADExpr exp) (map fst args)
427 genFCall' _ (Right name) _ _ = error $ "\nGenerate.genFCall': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
429 genFromSizedWord :: BuiltinBuilder
430 genFromSizedWord = genNoInsts $ genExprArgs genFromSizedWord'
431 genFromSizedWord' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [(AST.Expr, Type.Type)] -> TranslatorSession [AST.ConcSm]
432 genFromSizedWord' (Left res) f args@[(arg,_)] =
433 return [mkUncondAssign (Left res) arg]
434 -- let fname = varToString f
435 -- return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId toIntegerId)) $
436 -- map (\exp -> Nothing AST.:=>: AST.ADExpr exp) args
437 genFromSizedWord' (Right name) _ _ = error $ "\nGenerate.genFromSizedWord': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
439 genFromRangedWord :: BuiltinBuilder
440 genFromRangedWord = genNoInsts $ genExprArgs $ genExprRes genFromRangedWord'
441 genFromRangedWord' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [(AST.Expr, Type.Type)] -> TranslatorSession AST.Expr
442 genFromRangedWord' (Left res) f [(arg,_)] = do {
443 ; let { ty = Var.varType res
444 ; (tycon, args) = Type.splitTyConApp ty
445 ; name = Name.getOccString (TyCon.tyConName tycon)
447 ; len <- MonadState.lift tsType $ tfp_to_int (sized_word_len_ty ty)
448 ; return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId resizeId))
449 [Nothing AST.:=>: AST.ADExpr arg, Nothing AST.:=>: AST.ADExpr( AST.PrimLit (show len))]
451 genFromRangedWord' (Right name) _ _ = error $ "\nGenerate.genFromRangedWord': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
453 genResize :: BuiltinBuilder
454 genResize = genNoInsts $ genExprArgs $ genExprRes genResize'
455 genResize' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [(AST.Expr, Type.Type)] -> TranslatorSession AST.Expr
456 genResize' (Left res) f [(arg,_)] = do {
457 ; let { ty = Var.varType res
458 ; (tycon, args) = Type.splitTyConApp ty
459 ; name = Name.getOccString (TyCon.tyConName tycon)
461 ; len <- case name of
462 "Signed" -> MonadState.lift tsType $ tfp_to_int (sized_int_len_ty ty)
463 "Unsigned" -> MonadState.lift tsType $ tfp_to_int (sized_word_len_ty ty)
464 ; return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId resizeId))
465 [Nothing AST.:=>: AST.ADExpr arg, Nothing AST.:=>: AST.ADExpr( AST.PrimLit (show len))]
467 genResize' (Right name) _ _ = error $ "\nGenerate.genFromSizedWord': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
469 genTimes :: BuiltinBuilder
470 genTimes = genNoInsts $ genExprArgs $ genExprRes genTimes'
471 genTimes' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [(AST.Expr, Type.Type)] -> TranslatorSession AST.Expr
472 genTimes' (Left res) f [(arg1,_),(arg2,_)] = do {
473 ; let { ty = Var.varType res
474 ; (tycon, args) = Type.splitTyConApp ty
475 ; name = Name.getOccString (TyCon.tyConName tycon)
477 ; len <- case name of
478 "Signed" -> MonadState.lift tsType $ tfp_to_int (sized_int_len_ty ty)
479 "Unsigned" -> MonadState.lift tsType $ tfp_to_int (sized_word_len_ty ty)
480 "Index" -> do { ubound <- MonadState.lift tsType $ tfp_to_int (ranged_word_bound_ty ty)
481 ; let bitsize = floor (logBase 2 (fromInteger (toInteger ubound)))
484 ; return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId resizeId))
485 [Nothing AST.:=>: AST.ADExpr (arg1 AST.:*: arg2), Nothing AST.:=>: AST.ADExpr( AST.PrimLit (show len))]
487 genTimes' (Right name) _ _ = error $ "\nGenerate.genTimes': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
489 -- fromInteger turns an Integer into a Num instance. Since Integer is
490 -- not representable and is only allowed for literals, the actual
491 -- Integer should be inlined entirely into the fromInteger argument.
492 genFromInteger :: BuiltinBuilder
493 genFromInteger = genNoInsts $ genCoreArgs $ genExprRes genFromInteger'
494 genFromInteger' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [CoreSyn.CoreExpr] -> TranslatorSession AST.Expr
495 genFromInteger' (Left res) f args = do
496 let ty = Var.varType res
497 let (tycon, tyargs) = Type.splitTyConApp ty
498 let name = Name.getOccString (TyCon.tyConName tycon)
500 "Signed" -> MonadState.lift tsType $ tfp_to_int (sized_int_len_ty ty)
501 "Unsigned" -> MonadState.lift tsType $ tfp_to_int (sized_word_len_ty ty)
503 bound <- MonadState.lift tsType $ tfp_to_int (ranged_word_bound_ty ty)
504 return $ (ceiling (logBase 2 (fromInteger (toInteger (bound)))))
505 let fname = case name of "Signed" -> toSignedId ; "Unsigned" -> toUnsignedId ; "Index" -> toUnsignedId
507 [integer] -> do -- The type and dictionary arguments are removed by genApplication
508 literal <- getIntegerLiteral integer
509 return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId fname))
510 [Nothing AST.:=>: AST.ADExpr (AST.PrimLit (show literal)), Nothing AST.:=>: AST.ADExpr( AST.PrimLit (show len))]
511 _ -> error $ "\nGenerate.genFromInteger': Wrong number of arguments to genInteger. Applying " ++ pprString f ++ " to " ++ pprString args
513 genFromInteger' (Right name) _ _ = error $ "\nGenerate.genFromInteger': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
515 genSizedInt :: BuiltinBuilder
516 genSizedInt = genFromInteger
519 -- This function is useful for use with vectorTH, since that generates
520 -- explicit references to the TFVec constructor (which is normally
521 -- hidden). Below implementation is probably not current anymore, but
522 -- kept here in case we start using vectorTH again.
523 -- | Generate a Builder for the builtin datacon TFVec
524 genTFVec :: BuiltinBuilder
525 genTFVec (Left res) f [Left (CoreSyn.Let (CoreSyn.Rec letBinders) letRes)] = do {
526 -- Generate Assignments for all the binders
527 ; letAssigns <- mapM genBinderAssign letBinders
528 -- Generate assignments for the result (which might be another let binding)
529 ; (resBinders,resAssignments) <- genResAssign letRes
530 -- Get all the Assigned binders
531 ; let assignedBinders = Maybe.catMaybes (map fst letAssigns)
532 -- Make signal names for all the assigned binders
533 ; sigs <- mapM (\x -> MonadState.lift tsType $ varToVHDLExpr x) (assignedBinders ++ resBinders)
534 -- Assign all the signals to the resulting vector
535 ; let { vecsigns = mkAggregateSignal sigs
536 ; vecassign = mkUncondAssign (Left res) vecsigns
538 -- Generate all the signal declaration for the assigned binders
539 ; sig_dec_maybes <- mapM mkSigDec (assignedBinders ++ resBinders)
540 ; let { sig_decs = map (AST.BDISD) (Maybe.catMaybes $ sig_dec_maybes)
541 -- Setup the VHDL Block
542 ; block_label = mkVHDLExtId ("TFVec_" ++ show (varToString res))
543 ; block = AST.BlockSm block_label [] (AST.PMapAspect []) sig_decs ((concat (map snd letAssigns)) ++ resAssignments ++ [vecassign])
545 -- Return the block statement coressponding to the TFVec literal
546 ; return $ [AST.CSBSm block]
549 genBinderAssign :: (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -> TranslatorSession (Maybe CoreSyn.CoreBndr, [AST.ConcSm])
550 -- For now we only translate applications
551 genBinderAssign (bndr, app@(CoreSyn.App _ _)) = do
552 let (CoreSyn.Var f, args) = CoreSyn.collectArgs app
553 let valargs = get_val_args (Var.varType f) args
554 apps <- genApplication (Left bndr) f (map Left valargs)
555 return (Just bndr, apps)
556 genBinderAssign _ = return (Nothing,[])
557 genResAssign :: CoreSyn.CoreExpr -> TranslatorSession ([CoreSyn.CoreBndr], [AST.ConcSm])
558 genResAssign app@(CoreSyn.App _ letexpr) = do
560 (CoreSyn.Let (CoreSyn.Rec letbndrs) letres) -> do
561 letapps <- mapM genBinderAssign letbndrs
562 let bndrs = Maybe.catMaybes (map fst letapps)
563 let app = (map snd letapps)
564 (vars, apps) <- genResAssign letres
565 return ((bndrs ++ vars),((concat app) ++ apps))
566 otherwise -> return ([],[])
567 genResAssign _ = return ([],[])
569 genTFVec (Left res) f [Left app@(CoreSyn.App _ _)] = do {
570 ; let { elems = reduceCoreListToHsList app
571 -- Make signal names for all the binders
572 ; binders = map (\expr -> case expr of
574 otherwise -> error $ "\nGenerate.genTFVec: Cannot generate TFVec: "
575 ++ show res ++ ", with elems:\n" ++ show elems ++ "\n" ++ pprString elems) elems
577 ; sigs <- mapM (\x -> MonadState.lift tsType $ varToVHDLExpr x) binders
578 -- Assign all the signals to the resulting vector
579 ; let { vecsigns = mkAggregateSignal sigs
580 ; vecassign = mkUncondAssign (Left res) vecsigns
581 -- Setup the VHDL Block
582 ; block_label = mkVHDLExtId ("TFVec_" ++ show (varToString res))
583 ; block = AST.BlockSm block_label [] (AST.PMapAspect []) [] [vecassign]
585 -- Return the block statement coressponding to the TFVec literal
586 ; return $ [AST.CSBSm block]
589 genTFVec (Left name) _ [Left xs] = error $ "\nGenerate.genTFVec: Cannot generate TFVec: " ++ show name ++ ", with elems:\n" ++ show xs ++ "\n" ++ pprString xs
591 genTFVec (Right name) _ _ = error $ "\nGenerate.genTFVec: Cannot generate TFVec assigned to VHDLName: " ++ show name
593 -- | Generate a generate statement for the builtin function "map"
594 genMap :: BuiltinBuilder
595 genMap (Left res) f [(Left mapped_f, _), (Left (CoreSyn.Var arg), _)] = do {
596 -- mapped_f must be a CoreExpr (since we can't represent functions as VHDL
597 -- expressions). arg must be a CoreExpr (and should be a CoreSyn.Var), since
598 -- we must index it (which we couldn't if it was a VHDL Expr, since only
599 -- VHDLNames can be indexed).
600 -- Setup the generate scheme
601 ; len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) res
602 ; let res_type = (tfvec_elem . Var.varType) res
603 -- TODO: Use something better than varToString
604 ; let { label = mkVHDLExtId ("mapVector" ++ (varToUniqString res))
605 ; n_id = mkVHDLBasicId "n"
606 ; n_expr = idToVHDLExpr n_id
607 ; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
608 ; genScheme = AST.ForGn n_id range
609 -- Create the content of the generate statement: Applying the mapped_f to
610 -- each of the elements in arg, storing to each element in res
611 ; resname = mkIndexedName (varToVHDLName res) n_expr
612 ; argexpr = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg) n_expr
613 ; (CoreSyn.Var real_f, already_mapped_args) = CoreSyn.collectArgs mapped_f
614 ; valargs = get_val_args (Var.varType real_f) already_mapped_args
616 ; (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)])
617 -- Return the generate statement
618 ; return ([AST.CSGSm $ AST.GenerateSm label genScheme [] app_concsms], used)
621 genMap' (Right name) _ _ = error $ "\nGenerate.genMap': Cannot generate map function call assigned to a VHDLName: " ++ show name
623 genZipWith :: BuiltinBuilder
624 genZipWith (Left res) f args@[(Left zipped_f, _), (Left (CoreSyn.Var arg1), _), (Left (CoreSyn.Var arg2), _)] = do {
625 -- Setup the generate scheme
626 ; len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) res
627 ; let res_type = (tfvec_elem . Var.varType) res
628 -- TODO: Use something better than varToString
629 ; let { label = mkVHDLExtId ("zipWithVector" ++ (varToUniqString res))
630 ; n_id = mkVHDLBasicId "n"
631 ; n_expr = idToVHDLExpr n_id
632 ; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
633 ; genScheme = AST.ForGn n_id range
634 -- Create the content of the generate statement: Applying the zipped_f to
635 -- each of the elements in arg1 and arg2, storing to each element in res
636 ; resname = mkIndexedName (varToVHDLName res) n_expr
637 ; (CoreSyn.Var real_f, already_mapped_args) = CoreSyn.collectArgs zipped_f
638 ; valargs = get_val_args (Var.varType real_f) already_mapped_args
639 ; argexpr1 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg1) n_expr
640 ; argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg2) n_expr
642 ; (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)])
643 -- Return the generate functions
644 ; return ([AST.CSGSm $ AST.GenerateSm label genScheme [] app_concsms], used)
647 genFoldl :: BuiltinBuilder
648 genFoldl = genFold True
650 genFoldr :: BuiltinBuilder
651 genFoldr = genFold False
653 genFold :: Bool -> BuiltinBuilder
654 genFold left res f args@[folded_f, start, (vec, vecType)] = do
655 len <- MonadState.lift tsType $ tfp_to_int (tfvec_len_ty vecType)
656 genFold' len left res f args
658 genFold' :: Int -> Bool -> BuiltinBuilder
659 -- Special case for an empty input vector, just assign start to res
660 genFold' len left (Left res) _ [_, (start, _), vec] | len == 0 = do
661 [arg] <- argsToVHDLExprs [start]
662 return ([mkUncondAssign (Left res) arg], [])
664 genFold' len left (Left res) f [(Left folded_f,_), (start,startType), (vec,vecType)] = do
665 [vecExpr] <- argsToVHDLExprs [vec]
667 --len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) vec
668 -- An expression for len-1
669 let len_min_expr = (AST.PrimLit $ show (len-1))
670 -- evec is (TFVec n), so it still needs an element type
671 let (nvec, _) = Type.splitAppTy vecType
672 -- Put the type of the start value in nvec, this will be the type of our
674 let tmp_ty = Type.mkAppTy nvec startType
675 let error_msg = "\nGenerate.genFold': Can not construct temp vector for element type: " ++ pprString tmp_ty
676 -- TODO: Handle Nothing
677 Just tmp_vhdl_ty <- MonadState.lift tsType $ vhdlTy error_msg tmp_ty
678 -- Setup the generate scheme
679 let gen_label = mkVHDLExtId ("foldlVector" ++ (show vecExpr))
680 let block_label = mkVHDLExtId ("foldlVector" ++ (varToUniqString res))
681 let gen_range = if left then AST.ToRange (AST.PrimLit "0") len_min_expr
682 else AST.DownRange len_min_expr (AST.PrimLit "0")
683 let gen_scheme = AST.ForGn n_id gen_range
684 -- Make the intermediate vector
685 let tmp_dec = AST.BDISD $ AST.SigDec tmp_id tmp_vhdl_ty Nothing
686 -- Create the generate statement
687 cells' <- sequence [genFirstCell, genOtherCell]
688 let (cells, useds) = unzip cells'
689 let gen_sm = AST.GenerateSm gen_label gen_scheme [] (map AST.CSGSm cells)
690 -- Assign tmp[len-1] or tmp[0] to res
691 let out_assign = mkUncondAssign (Left res) $ vhdlNameToVHDLExpr (if left then
692 (mkIndexedName tmp_name (AST.PrimLit $ show (len-1))) else
693 (mkIndexedName tmp_name (AST.PrimLit "0")))
694 let block = AST.BlockSm block_label [] (AST.PMapAspect []) [tmp_dec] [AST.CSGSm gen_sm, out_assign]
695 return ([AST.CSBSm block], concat useds)
697 -- An id for the counter
698 n_id = mkVHDLBasicId "n"
699 n_cur = idToVHDLExpr n_id
700 -- An expression for previous n
701 n_prev = if left then (n_cur AST.:-: (AST.PrimLit "1"))
702 else (n_cur AST.:+: (AST.PrimLit "1"))
703 -- An id for the tmp result vector
704 tmp_id = mkVHDLBasicId "tmp"
705 tmp_name = AST.NSimple tmp_id
706 -- Generate parts of the fold
707 genFirstCell, genOtherCell :: TranslatorSession (AST.GenerateSm, [CoreSyn.CoreBndr])
709 [AST.PrimName vecName, argexpr1] <- argsToVHDLExprs [vec,start]
710 let res_type = (tfvec_elem . Var.varType) res
711 len <- MonadState.lift tsType $ tfp_to_int $ tfvec_len_ty vecType
712 let cond_label = mkVHDLExtId "firstcell"
713 -- if n == 0 or n == len-1
714 let cond_scheme = AST.IfGn $ n_cur AST.:=: (if left then (AST.PrimLit "0")
715 else (AST.PrimLit $ show (len-1)))
716 -- Output to tmp[current n]
717 let resname = mkIndexedName tmp_name n_cur
719 -- argexpr1 <- MonadState.lift tsType $ varToVHDLExpr start
720 -- Input from vec[current n]
721 let argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName vecName n_cur
722 let (CoreSyn.Var real_f, already_mapped_args) = CoreSyn.collectArgs folded_f
723 let valargs = get_val_args (Var.varType real_f) already_mapped_args
724 (app_concsms, used) <- genApplication (Right resname,res_type) real_f ((zip (map Left valargs) (map CoreUtils.exprType valargs)) ++ ( if left then
725 [(Right argexpr1, startType), (Right argexpr2, tfvec_elem vecType)]
727 [(Right argexpr2, tfvec_elem vecType), (Right argexpr1, startType)]
729 -- Return the conditional generate part
730 return (AST.GenerateSm cond_label cond_scheme [] app_concsms, used)
733 [AST.PrimName vecName] <- argsToVHDLExprs [vec]
734 let res_type = (tfvec_elem . Var.varType) res
735 len <- MonadState.lift tsType $ tfp_to_int $ tfvec_len_ty vecType
736 let cond_label = mkVHDLExtId "othercell"
737 -- if n > 0 or n < len-1
738 let cond_scheme = AST.IfGn $ n_cur AST.:/=: (if left then (AST.PrimLit "0")
739 else (AST.PrimLit $ show (len-1)))
740 -- Output to tmp[current n]
741 let resname = mkIndexedName tmp_name n_cur
742 -- Input from tmp[previous n]
743 let argexpr1 = vhdlNameToVHDLExpr $ mkIndexedName tmp_name n_prev
744 -- Input from vec[current n]
745 let argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName vecName n_cur
746 let (CoreSyn.Var real_f, already_mapped_args) = CoreSyn.collectArgs folded_f
747 let valargs = get_val_args (Var.varType real_f) already_mapped_args
748 (app_concsms, used) <- genApplication (Right resname,res_type) real_f ((zip (map Left valargs) (map CoreUtils.exprType valargs)) ++ ( if left then
749 [(Right argexpr1, startType), (Right argexpr2, tfvec_elem vecType)]
751 [(Right argexpr2, tfvec_elem vecType), (Right argexpr1, startType)]
753 -- Return the conditional generate part
754 return (AST.GenerateSm cond_label cond_scheme [] app_concsms, used)
756 -- | Generate a generate statement for the builtin function "zip"
757 genZip :: BuiltinBuilder
758 genZip = genNoInsts genZip'
759 genZip' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [(Either CoreSyn.CoreExpr AST.Expr, Type.Type)] -> TranslatorSession [AST.ConcSm]
760 genZip' (Left res) f args@[(arg1,_), (arg2,_)] = do {
761 -- Setup the generate scheme
762 ; len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) res
763 ; res_htype <- MonadState.lift tsType $ mkHType "\nGenerate.genZip: Invalid result type" (tfvec_elem (Var.varType res))
764 ; [AST.PrimName argName1, AST.PrimName argName2] <- argsToVHDLExprs [arg1,arg2]
765 -- TODO: Use something better than varToString
766 ; let { label = mkVHDLExtId ("zipVector" ++ (varToUniqString res))
767 ; n_id = mkVHDLBasicId "n"
768 ; n_expr = idToVHDLExpr n_id
769 ; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
770 ; genScheme = AST.ForGn n_id range
771 ; resname' = mkIndexedName (varToVHDLName res) n_expr
772 ; argexpr1 = vhdlNameToVHDLExpr $ mkIndexedName argName1 n_expr
773 ; argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName argName2 n_expr
774 ; labels = getFieldLabels res_htype 0
776 ; let { resnameA = mkSelectedName resname' (labels!!0)
777 ; resnameB = mkSelectedName resname' (labels!!1)
778 ; resA_assign = mkUncondAssign (Right resnameA) argexpr1
779 ; resB_assign = mkUncondAssign (Right resnameB) argexpr2
781 -- Return the generate functions
782 ; return [AST.CSGSm $ AST.GenerateSm label genScheme [] [resA_assign,resB_assign]]
785 -- | Generate a generate statement for the builtin function "fst"
786 genFst :: BuiltinBuilder
787 genFst = genNoInsts genFst'
788 genFst' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [(Either CoreSyn.CoreExpr AST.Expr, Type.Type)] -> TranslatorSession [AST.ConcSm]
789 genFst' res f args@[(arg,argType)] = do {
790 ; arg_htype <- MonadState.lift tsType $ mkHType "\nGenerate.genFst: Invalid argument type" argType
791 ; [AST.PrimName argExpr] <- argsToVHDLExprs [arg]
793 ; labels = getFieldLabels arg_htype 0
794 ; argexprA = vhdlNameToVHDLExpr $ mkSelectedName argExpr (labels!!0)
795 ; assign = mkUncondAssign res argexprA
797 -- Return the generate functions
801 -- | Generate a generate statement for the builtin function "snd"
802 genSnd :: BuiltinBuilder
803 genSnd = genNoInsts genSnd'
804 genSnd' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [(Either CoreSyn.CoreExpr AST.Expr, Type.Type)] -> TranslatorSession [AST.ConcSm]
805 genSnd' (Left res) f args@[(arg,argType)] = do {
806 ; arg_htype <- MonadState.lift tsType $ mkHType "\nGenerate.genSnd: Invalid argument type" argType
807 ; [AST.PrimName argExpr] <- argsToVHDLExprs [arg]
809 ; labels = getFieldLabels arg_htype 0
810 ; argexprB = vhdlNameToVHDLExpr $ mkSelectedName argExpr (labels!!1)
811 ; assign = mkUncondAssign (Left res) argexprB
813 -- Return the generate functions
817 -- | Generate a generate statement for the builtin function "unzip"
818 genUnzip :: BuiltinBuilder
819 genUnzip = genNoInsts genUnzip'
820 genUnzip' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [(Either CoreSyn.CoreExpr AST.Expr, Type.Type)] -> TranslatorSession [AST.ConcSm]
821 genUnzip' (Left res) f args@[(arg,argType)] = do
822 let error_msg = "\nGenerate.genUnzip: Cannot generate unzip call: " ++ pprString res ++ " = " ++ pprString f ++ " " ++ show arg
823 htype <- MonadState.lift tsType $ mkHType error_msg argType
824 -- Prepare a unconditional assignment, for the case when either part
825 -- of the unzip is a state variable, which will disappear in the
826 -- resulting VHDL, making the the unzip no longer required.
828 -- A normal vector containing two-tuples
829 VecType _ (AggrType _ _ [_, _]) -> do {
830 -- Setup the generate scheme
831 ; len <- MonadState.lift tsType $ tfp_to_int $ tfvec_len_ty argType
832 ; arg_htype <- MonadState.lift tsType $ mkHType "\nGenerate.genUnzip: Invalid argument type" argType
833 ; res_htype <- MonadState.lift tsType $ mkHType "\nGenerate.genUnzip: Invalid result type" (Var.varType res)
834 ; [AST.PrimName arg'] <- argsToVHDLExprs [arg]
835 -- TODO: Use something better than varToString
836 ; let { label = mkVHDLExtId ("unzipVector" ++ (varToUniqString res))
837 ; n_id = mkVHDLBasicId "n"
838 ; n_expr = idToVHDLExpr n_id
839 ; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
840 ; genScheme = AST.ForGn n_id range
841 ; resname' = varToVHDLName res
842 ; argexpr' = mkIndexedName arg' n_expr
843 ; reslabels = getFieldLabels res_htype 0
844 ; arglabels = getFieldLabels arg_htype 0
846 ; let { resnameA = mkIndexedName (mkSelectedName resname' (reslabels!!0)) n_expr
847 ; resnameB = mkIndexedName (mkSelectedName resname' (reslabels!!1)) n_expr
848 ; argexprA = vhdlNameToVHDLExpr $ mkSelectedName argexpr' (arglabels!!0)
849 ; argexprB = vhdlNameToVHDLExpr $ mkSelectedName argexpr' (arglabels!!1)
850 ; resA_assign = mkUncondAssign (Right resnameA) argexprA
851 ; resB_assign = mkUncondAssign (Right resnameB) argexprB
853 -- Return the generate functions
854 ; return [AST.CSGSm $ AST.GenerateSm label genScheme [] [resA_assign,resB_assign]]
856 -- Both elements of the tuple were state, so they've disappeared. No
857 -- need to do anything
858 VecType _ (AggrType _ _ []) -> return []
859 -- A vector containing aggregates with more than two elements?
860 VecType _ (AggrType _ _ _) -> error $ "Unzipping a value that is not a vector of two-tuples? Value: " ++ show arg ++ "\nType: " ++ pprString argType
861 -- One of the elements of the tuple was state, so there won't be a
862 -- tuple (record) in the VHDL output. We can just do a plain
865 [argexpr] <- argsToVHDLExprs [arg]
866 return [mkUncondAssign (Left res) argexpr]
867 _ -> error $ "Unzipping a value that is not a vector? Value: " ++ show arg ++ "\nType: " ++ pprString argType ++ "\nhtype: " ++ show htype
869 genCopy :: BuiltinBuilder
870 genCopy = genNoInsts genCopy'
871 genCopy' :: (Either CoreSyn.CoreBndr AST.VHDLName ) -> CoreSyn.CoreBndr -> [(Either CoreSyn.CoreExpr AST.Expr, Type.Type)] -> TranslatorSession [AST.ConcSm]
872 genCopy' (Left res) f [(arg,argType)] = do {
873 ; [arg'] <- argsToVHDLExprs [arg]
874 ; let { resExpr = AST.Aggregate [AST.ElemAssoc (Just AST.Others) arg']
875 ; out_assign = mkUncondAssign (Left res) resExpr
877 ; return [out_assign]
880 genConcat :: BuiltinBuilder
881 genConcat = genNoInsts genConcat'
882 genConcat' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [(Either CoreSyn.CoreExpr AST.Expr, Type.Type)] -> TranslatorSession [AST.ConcSm]
883 genConcat' (Left res) f args@[(arg,argType)] = do {
884 -- Setup the generate scheme
885 ; len1 <- MonadState.lift tsType $ tfp_to_int $ tfvec_len_ty argType
886 ; let (_, nvec) = Type.splitAppTy argType
887 ; len2 <- MonadState.lift tsType $ tfp_to_int $ tfvec_len_ty nvec
888 ; [AST.PrimName argName] <- argsToVHDLExprs [arg]
889 -- TODO: Use something better than varToString
890 ; let { label = mkVHDLExtId ("concatVector" ++ (varToUniqString res))
891 ; n_id = mkVHDLBasicId "n"
892 ; n_expr = idToVHDLExpr n_id
893 ; fromRange = n_expr AST.:*: (AST.PrimLit $ show len2)
894 ; genScheme = AST.ForGn n_id range
895 -- Create the content of the generate statement: Applying the mapped_f to
896 -- each of the elements in arg, storing to each element in res
897 ; toRange = (n_expr AST.:*: (AST.PrimLit $ show len2)) AST.:+: (AST.PrimLit $ show (len2-1))
898 ; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len1-1))
899 ; resname = vecSlice fromRange toRange
900 ; argexpr = vhdlNameToVHDLExpr $ mkIndexedName argName n_expr
901 ; out_assign = mkUncondAssign (Right resname) argexpr
903 -- Return the generate statement
904 ; return [AST.CSGSm $ AST.GenerateSm label genScheme [] [out_assign]]
907 vecSlice init last = AST.NSlice (AST.SliceName (varToVHDLName res)
908 (AST.ToRange init last))
910 genIteraten :: BuiltinBuilder
911 genIteraten dst f args = genIterate dst f (tail args)
913 genIterate :: BuiltinBuilder
914 genIterate = genIterateOrGenerate True
916 genGeneraten :: BuiltinBuilder
917 genGeneraten dst f args = genGenerate dst f (tail args)
919 genGenerate :: BuiltinBuilder
920 genGenerate = genIterateOrGenerate False
922 genIterateOrGenerate :: Bool -> BuiltinBuilder
923 genIterateOrGenerate iter (Left res) f args = do
924 len <- MonadState.lift tsType $ tfp_to_int ((tfvec_len_ty . Var.varType) res)
925 genIterateOrGenerate' len iter (Left res) f args
927 genIterateOrGenerate' :: Int -> Bool -> BuiltinBuilder
928 -- Special case for an empty input vector, just assign start to res
929 genIterateOrGenerate' len iter (Left res) _ [app_f, start] | len == 0 = return ([mkUncondAssign (Left res) (AST.PrimLit "\"\"")], [])
931 genIterateOrGenerate' len iter (Left res) f [(Left app_f,_), (start,startType)] = do
933 -- len <- MonadState.lift tsType $ tfp_to_int ((tfvec_len_ty . Var.varType) res)
934 -- An expression for len-1
935 let len_min_expr = (AST.PrimLit $ show (len-1))
936 -- -- evec is (TFVec n), so it still needs an element type
937 -- let (nvec, _) = splitAppTy (Var.varType vec)
938 -- -- Put the type of the start value in nvec, this will be the type of our
939 -- -- temporary vector
940 let tmp_ty = Var.varType res
941 let error_msg = "\nGenerate.genFold': Can not construct temp vector for element type: " ++ pprString tmp_ty
942 -- TODO: Handle Nothing
943 Just tmp_vhdl_ty <- MonadState.lift tsType $ vhdlTy error_msg tmp_ty
944 -- Setup the generate scheme
945 [startExpr] <- argsToVHDLExprs [start]
946 let gen_label = mkVHDLExtId ("iterateVector" ++ (show startExpr))
947 let block_label = mkVHDLExtId ("iterateVector" ++ (varToUniqString res))
948 let gen_range = AST.ToRange (AST.PrimLit "0") len_min_expr
949 let gen_scheme = AST.ForGn n_id gen_range
950 -- Make the intermediate vector
951 let tmp_dec = AST.BDISD $ AST.SigDec tmp_id tmp_vhdl_ty Nothing
952 -- Create the generate statement
953 cells' <- sequence [genFirstCell, genOtherCell]
954 let (cells, useds) = unzip cells'
955 let gen_sm = AST.GenerateSm gen_label gen_scheme [] (map AST.CSGSm cells)
956 -- Assign tmp[len-1] or tmp[0] to res
957 let out_assign = mkUncondAssign (Left res) $ vhdlNameToVHDLExpr tmp_name
958 let block = AST.BlockSm block_label [] (AST.PMapAspect []) [tmp_dec] [AST.CSGSm gen_sm, out_assign]
959 return ([AST.CSBSm block], concat useds)
961 -- An id for the counter
962 n_id = mkVHDLBasicId "n"
963 n_cur = idToVHDLExpr n_id
964 -- An expression for previous n
965 n_prev = n_cur AST.:-: (AST.PrimLit "1")
966 -- An id for the tmp result vector
967 tmp_id = mkVHDLBasicId "tmp"
968 tmp_name = AST.NSimple tmp_id
969 -- Generate parts of the fold
970 genFirstCell, genOtherCell :: TranslatorSession (AST.GenerateSm, [CoreSyn.CoreBndr])
972 let res_type = (tfvec_elem . Var.varType) res
973 let cond_label = mkVHDLExtId "firstcell"
974 -- if n == 0 or n == len-1
975 let cond_scheme = AST.IfGn $ n_cur AST.:=: (AST.PrimLit "0")
976 -- Output to tmp[current n]
977 let resname = mkIndexedName tmp_name n_cur
979 [argexpr] <- argsToVHDLExprs [start]
980 let startassign = mkUncondAssign (Right resname) argexpr
981 let (CoreSyn.Var real_f, already_mapped_args) = CoreSyn.collectArgs app_f
982 let valargs = get_val_args (Var.varType real_f) already_mapped_args
983 (app_concsms, used) <- genApplication (Right resname, res_type) real_f ((zip (map Left valargs) (map CoreUtils.exprType valargs)) ++ [(Right argexpr, startType)])
984 -- Return the conditional generate part
985 let gensm = AST.GenerateSm cond_label cond_scheme [] (if iter then
993 let res_type = (tfvec_elem . Var.varType) res
994 let cond_label = mkVHDLExtId "othercell"
995 -- if n > 0 or n < len-1
996 let cond_scheme = AST.IfGn $ n_cur AST.:/=: (AST.PrimLit "0")
997 -- Output to tmp[current n]
998 let resname = mkIndexedName tmp_name n_cur
999 -- Input from tmp[previous n]
1000 let argexpr = vhdlNameToVHDLExpr $ mkIndexedName tmp_name n_prev
1001 let (CoreSyn.Var real_f, already_mapped_args) = CoreSyn.collectArgs app_f
1002 let valargs = get_val_args (Var.varType real_f) already_mapped_args
1003 (app_concsms, used) <- genApplication (Right resname, res_type) real_f ((zip (map Left valargs) (map CoreUtils.exprType valargs)) ++ [(Right argexpr, res_type)])
1004 -- Return the conditional generate part
1005 return (AST.GenerateSm cond_label cond_scheme [] app_concsms, used)
1007 genBlockRAM :: BuiltinBuilder
1008 genBlockRAM = genNoInsts $ genExprArgs genBlockRAM'
1010 genBlockRAM' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [(AST.Expr,Type.Type)] -> TranslatorSession [AST.ConcSm]
1011 genBlockRAM' (Left res) f args@[data_in,rdaddr,wraddr,wrenable] = do
1013 let (tup,data_out) = Type.splitAppTy (Var.varType res)
1014 let (tup',ramvec) = Type.splitAppTy tup
1015 let Just realram = Type.coreView ramvec
1016 let Just (tycon, types) = Type.splitTyConApp_maybe realram
1017 Just ram_vhdl_ty <- MonadState.lift tsType $ vhdlTy "wtf" (head types)
1018 -- Make the intermediate vector
1019 let ram_dec = AST.BDISD $ AST.SigDec ram_id ram_vhdl_ty Nothing
1020 -- Get the data_out name
1021 -- reslabels <- MonadState.lift tsType $ getFieldLabels (Var.varType res)
1022 let resname = varToVHDLName res
1023 -- let resname = mkSelectedName resname' (reslabels!!0)
1024 let rdaddr_int = genExprFCall (mkVHDLBasicId toIntegerId) $ fst rdaddr
1025 let argexpr = vhdlNameToVHDLExpr $ mkIndexedName (AST.NSimple ram_id) rdaddr_int
1026 let assign = mkUncondAssign (Right resname) argexpr
1027 let block_label = mkVHDLExtId ("blockRAM" ++ (varToUniqString res))
1028 let block = AST.BlockSm block_label [] (AST.PMapAspect []) [ram_dec] [assign, mkUpdateProcSm]
1029 return [AST.CSBSm block]
1031 ram_id = mkVHDLBasicId "ram"
1032 mkUpdateProcSm :: AST.ConcSm
1033 mkUpdateProcSm = AST.CSPSm $ AST.ProcSm proclabel [clockId] [statement]
1035 proclabel = mkVHDLBasicId "updateRAM"
1036 rising_edge = mkVHDLBasicId "rising_edge"
1037 wraddr_int = genExprFCall (mkVHDLBasicId toIntegerId) $ fst wraddr
1038 ramloc = mkIndexedName (AST.NSimple ram_id) wraddr_int
1039 wform = AST.Wform [AST.WformElem (fst data_in) Nothing]
1040 ramassign = AST.SigAssign ramloc wform
1041 rising_edge_clk = genExprFCall rising_edge (AST.PrimName $ AST.NSimple clockId)
1042 statement = AST.IfSm (AST.And rising_edge_clk $ fst wrenable) [ramassign] [] Nothing
1044 genSplit :: BuiltinBuilder
1045 genSplit = genNoInsts genSplit'
1047 genSplit' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [(Either CoreSyn.CoreExpr AST.Expr, Type.Type)] -> TranslatorSession [AST.ConcSm]
1048 genSplit' (Left res) f args@[(vecIn,vecInType)] = do {
1049 ; len <- MonadState.lift tsType $ tfp_to_int $ tfvec_len_ty vecInType
1050 ; res_htype <- MonadState.lift tsType $ mkHType "\nGenerate.genSplit': Invalid result type" (Var.varType res)
1051 ; [argExpr] <- argsToVHDLExprs [vecIn]
1053 ; labels = getFieldLabels res_htype 0
1054 ; block_label = mkVHDLExtId ("split" ++ show argExpr)
1055 ; halflen = round ((fromIntegral len) / 2)
1056 ; rangeL = vecSlice (AST.PrimLit "0") (AST.PrimLit $ show (halflen - 1))
1057 ; rangeR = vecSlice (AST.PrimLit $ show halflen) (AST.PrimLit $ show (len - 1))
1058 ; resname = varToVHDLName res
1059 ; resnameL = mkSelectedName resname (labels!!0)
1060 ; resnameR = mkSelectedName resname (labels!!1)
1061 ; argexprL = vhdlNameToVHDLExpr rangeL
1062 ; argexprR = vhdlNameToVHDLExpr rangeR
1063 ; out_assignL = mkUncondAssign (Right resnameL) argexprL
1064 ; out_assignR = mkUncondAssign (Right resnameR) argexprR
1065 ; block = AST.BlockSm block_label [] (AST.PMapAspect []) [] [out_assignL, out_assignR]
1067 ; return [AST.CSBSm block]
1070 vecSlice init last = AST.NSlice (AST.SliceName (varToVHDLName res)
1071 (AST.ToRange init last))
1073 genSll :: BuiltinBuilder
1074 genSll = genNoInsts $ genExprArgs $ genExprRes genSll'
1075 genSll' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [(AST.Expr, Type.Type)] -> TranslatorSession AST.Expr
1076 genSll' res f [(arg1,_),(arg2,_)] = do {
1077 ; return $ (AST.Sll arg1 (genExprFCall (mkVHDLBasicId toIntegerId) arg2))
1080 genSra :: BuiltinBuilder
1081 genSra = genNoInsts $ genExprArgs $ genExprRes genSra'
1082 genSra' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [(AST.Expr, Type.Type)] -> TranslatorSession AST.Expr
1083 genSra' res f [(arg1,_),(arg2,_)] = do {
1084 ; return $ (AST.Sra arg1 (genExprFCall (mkVHDLBasicId toIntegerId) arg2))
1087 -----------------------------------------------------------------------------
1088 -- Function to generate VHDL for applications
1089 -----------------------------------------------------------------------------
1091 (Either CoreSyn.CoreBndr AST.VHDLName, Type.Type) -- ^ Where to store the result?
1092 -> CoreSyn.CoreBndr -- ^ The function to apply
1093 -> [(Either CoreSyn.CoreExpr AST.Expr, Type.Type)] -- ^ The arguments to apply
1094 -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
1095 -- ^ The corresponding VHDL concurrent statements and entities
1097 genApplication (dst, dsttype) f args = do
1098 nonemptydst <- case dst of
1099 Left bndr -> hasNonEmptyType bndr
1100 Right _ -> return True
1103 if Var.isGlobalId f then
1104 case Var.idDetails f of
1105 IdInfo.DataConWorkId dc -> do -- case dst of
1106 -- It's a datacon. Create a record from its arguments.
1108 -- We have the bndr, so we can get at the type
1109 htype_either <- MonadState.lift tsType $ mkHTypeEither dsttype
1110 let argsNoState = filter (\x -> not (either hasStateType (\x -> False) x)) (map fst args)
1111 let dcs = datacons_for dsttype
1112 case (dcs, argsNoState) of
1113 -- This is a type with a single datacon and a single
1114 -- argument, so no record is created (the type of the
1115 -- binder becomes the type of the single argument).
1117 [arg'] <- argsToVHDLExprs [arg]
1118 return ([mkUncondAssign dst arg'], [])
1119 -- In all other cases, a record type is created.
1120 _ -> case htype_either of
1121 Right htype@(AggrType _ etype _) -> do
1122 let dc_i = datacon_index dsttype dc
1123 let labels = getFieldLabels htype dc_i
1124 arg_exprs <- argsToVHDLExprs argsNoState
1125 let (final_labels, final_exprs) = case getConstructorFieldLabel htype of
1126 -- Only a single constructor
1129 -- Multiple constructors, so assign the
1130 -- constructor used to the constructor field as
1133 let { dc_index = getConstructorIndex (snd $ Maybe.fromJust etype) (varToString f)
1134 ; dc_expr = AST.PrimLit $ show dc_index
1135 } in (dc_label:labels, dc_expr:arg_exprs)
1136 return (zipWith mkassign final_labels final_exprs, [])
1138 mkassign :: AST.VHDLId -> AST.Expr -> AST.ConcSm
1139 mkassign label arg =
1140 let sel_name = mkSelectedName ((either varToVHDLName id) dst) label in
1141 mkUncondAssign (Right sel_name) arg
1142 -- Enumeration types have no arguments and are just
1143 -- simple assignments
1144 Right (EnumType _ _) ->
1146 -- These builtin types are also enumeration types
1147 Right (BuiltinType tyname) | tyname `elem` ["Bit", "Bool"] ->
1149 Right _ -> error $ "Datacon application does not result in a aggregate type? datacon: " ++ pprString f ++ " Args: " ++ show args
1150 Left _ -> error $ "Unrepresentable result type in datacon application? datacon: " ++ pprString f ++ " Args: " ++ show args
1152 -- Simple uncoditional assignment, for (built-in)
1153 -- enumeration types
1155 expr <- MonadState.lift tsType $ dataconToVHDLExpr dc
1156 return ([mkUncondAssign dst expr], [])
1159 -- let dcs = datacons_for dsttype
1160 -- error $ "\nGenerate.genApplication(DataConWorkId): Can't generate dataconstructor application without an original binder" ++ show dcs
1161 IdInfo.DataConWrapId dc -> case dst of
1162 -- It's a datacon. Create a record from its arguments.
1164 case (Map.lookup (varToString f) globalNameTable) of
1165 Just (arg_count, builder) ->
1166 if length args == arg_count then
1169 error $ "\nGenerate.genApplication(DataConWrapId): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args
1170 Nothing -> error $ "\nGenerate.genApplication(DataConWrapId): Can't generate dataconwrapper: " ++ (show dc)
1171 Right _ -> error "\nGenerate.genApplication(DataConWrapId): Can't generate dataconwrapper application without an original binder"
1173 -- It's a global value imported from elsewhere. These can be builtin
1174 -- functions. Look up the function name in the name table and execute
1175 -- the associated builder if there is any and the argument count matches
1176 -- (this should always be the case if it typechecks, but just to be
1178 case (Map.lookup (varToString f) globalNameTable) of
1179 Just (arg_count, builder) ->
1180 if length args == arg_count then
1183 error $ "\nGenerate.genApplication(VanillaId): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args
1185 top <- isTopLevelBinder f
1188 -- Local binder that references a top level binding. Generate a
1189 -- component instantiation.
1190 signature <- getEntity f
1191 args' <- argsToVHDLExprs (map fst args)
1192 let entity_id = ent_id signature
1193 -- TODO: Using show here isn't really pretty, but we'll need some
1194 -- unique-ish value...
1195 let label = "comp_ins_" ++ (either show prettyShow) dst
1196 let portmaps = mkAssocElems args' ((either varToVHDLName id) dst) signature
1197 return ([mkComponentInst label entity_id portmaps], [f])
1199 -- Not a top level binder, so this must be a local variable reference.
1200 -- It should have a representable type (and thus, no arguments) and a
1201 -- signal should be generated for it. Just generate an unconditional
1203 -- FIXME : I DONT KNOW IF THE ABOVE COMMENT HOLDS HERE, SO FOR NOW JUST ERROR!
1204 -- f' <- MonadState.lift tsType $ varToVHDLExpr f
1205 -- return $ ([mkUncondAssign dst f'], [])
1206 do errtype <- case dst of
1208 htype <- MonadState.lift tsType $ mkHTypeEither (Var.varType bndr)
1210 Right vhd -> return $ show vhd
1211 error ("\nGenerate.genApplication(VanillaId): Using function from another module that is not a known builtin: " ++ (pprString f) ++ "::" ++ errtype)
1212 IdInfo.ClassOpId cls ->
1213 -- FIXME: Not looking for what instance this class op is called for
1214 -- Is quite stupid of course.
1215 case (Map.lookup (varToString f) globalNameTable) of
1216 Just (arg_count, builder) ->
1217 if length args == arg_count then
1220 error $ "\nGenerate.genApplication(ClassOpId): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args
1221 Nothing -> error $ "\nGenerate.genApplication(ClassOpId): Using function from another module that is not a known builtin: " ++ pprString f
1222 details -> error $ "\nGenerate.genApplication: Calling unsupported function " ++ pprString f ++ " with GlobalIdDetails " ++ pprString details
1224 top <- isTopLevelBinder f
1227 -- Local binder that references a top level binding. Generate a
1228 -- component instantiation.
1229 signature <- getEntity f
1230 args' <- argsToVHDLExprs (map fst args)
1231 let entity_id = ent_id signature
1232 -- TODO: Using show here isn't really pretty, but we'll need some
1233 -- unique-ish value...
1234 let label = "comp_ins_" ++ (either (prettyShow . varToVHDLName) prettyShow) dst
1235 let portmaps = mkAssocElems args' ((either varToVHDLName id) dst) signature
1236 return ([mkComponentInst label entity_id portmaps], [f])
1238 -- Not a top level binder, so this must be a local variable reference.
1239 -- It should have a representable type (and thus, no arguments) and a
1240 -- signal should be generated for it. Just generate an unconditional
1242 do f' <- MonadState.lift tsType $ varToVHDLExpr f
1243 return ([mkUncondAssign dst f'], [])
1244 else -- Destination has empty type, don't generate anything
1246 -----------------------------------------------------------------------------
1247 -- Functions to generate functions dealing with vectors.
1248 -----------------------------------------------------------------------------
1250 -- Returns the VHDLId of the vector function with the given name for the given
1251 -- element type. Generates -- this function if needed.
1252 vectorFunId :: Type.Type -> String -> TypeSession AST.VHDLId
1253 vectorFunId el_ty fname = do
1254 let error_msg = "\nGenerate.vectorFunId: Can not construct vector function for element: " ++ pprString el_ty
1255 -- TODO: Handle the Nothing case?
1256 elemTM_maybe <- vhdlTy error_msg el_ty
1257 let elemTM = Maybe.fromMaybe
1258 (error $ "\nGenerate.vectorFunId: Cannot generate vector function \"" ++ fname ++ "\" for the empty type \"" ++ (pprString el_ty) ++ "\"")
1260 -- TODO: This should not be duplicated from mk_vector_ty. Probably but it in
1261 -- the VHDLState or something.
1262 let vectorTM = mkVHDLExtId $ "vector_" ++ (AST.fromVHDLId elemTM)
1263 typefuns <- MonadState.get tsTypeFuns
1264 el_htype <- mkHType error_msg el_ty
1265 case Map.lookup (UVecType el_htype, fname) typefuns of
1266 -- Function already generated, just return it
1267 Just (id, _) -> return id
1268 -- Function not generated yet, generate it
1270 let functions = genUnconsVectorFuns elemTM vectorTM
1271 case lookup fname functions of
1273 MonadState.modify tsTypeFuns $ Map.insert (UVecType el_htype, fname) (function_id, (fst body))
1274 mapM_ (vectorFunId el_ty) (snd body)
1276 Nothing -> error $ "\nGenerate.vectorFunId: I don't know how to generate vector function " ++ fname
1278 function_id = mkVHDLExtId fname
1280 genUnconsVectorFuns :: AST.TypeMark -- ^ type of the vector elements
1281 -> AST.TypeMark -- ^ type of the vector
1282 -> [(String, (AST.SubProgBody, [String]))]
1283 genUnconsVectorFuns elemTM vectorTM =
1284 [ (exId, (AST.SubProgBody exSpec [] [exExpr],[]))
1285 , (replaceId, (AST.SubProgBody replaceSpec [AST.SPVD replaceVar] [replaceExpr1,replaceExpr2,replaceRet],[]))
1286 , (lastId, (AST.SubProgBody lastSpec [] [lastExpr],[]))
1287 , (initId, (AST.SubProgBody initSpec [AST.SPVD initVar] [initExpr, initRet],[]))
1288 , (minimumId, (AST.SubProgBody minimumSpec [] [minimumExpr],[]))
1289 , (takeId, (AST.SubProgBody takeSpec [AST.SPVD takeVar] [takeExpr, takeRet],[minimumId]))
1290 , (dropId, (AST.SubProgBody dropSpec [AST.SPVD dropVar] [dropExpr, dropRet],[]))
1291 , (plusgtId, (AST.SubProgBody plusgtSpec [AST.SPVD plusgtVar] [plusgtExpr, plusgtRet],[]))
1292 , (emptyId, (AST.SubProgBody emptySpec [AST.SPVD emptyVar] [emptyExpr],[]))
1293 , (singletonId, (AST.SubProgBody singletonSpec [AST.SPVD singletonVar] [singletonRet],[]))
1294 , (copynId, (AST.SubProgBody copynSpec [AST.SPVD copynVar] [copynExpr],[]))
1295 , (selId, (AST.SubProgBody selSpec [AST.SPVD selVar] [selFor, selRet],[]))
1296 , (ltplusId, (AST.SubProgBody ltplusSpec [AST.SPVD ltplusVar] [ltplusExpr, ltplusRet],[]))
1297 , (plusplusId, (AST.SubProgBody plusplusSpec [AST.SPVD plusplusVar] [plusplusExpr, plusplusRet],[]))
1298 , (lengthTId, (AST.SubProgBody lengthTSpec [] [lengthTExpr],[]))
1299 , (shiftIntoLId, (AST.SubProgBody shiftlSpec [AST.SPVD shiftlVar] [shiftlExpr, shiftlRet], [initId]))
1300 , (shiftIntoRId, (AST.SubProgBody shiftrSpec [AST.SPVD shiftrVar] [shiftrExpr, shiftrRet], [tailId]))
1301 , (nullId, (AST.SubProgBody nullSpec [] [nullExpr], []))
1302 , (rotlId, (AST.SubProgBody rotlSpec [AST.SPVD rotlVar] [rotlExpr, rotlRet], [nullId, lastId, initId]))
1303 , (rotrId, (AST.SubProgBody rotrSpec [AST.SPVD rotrVar] [rotrExpr, rotrRet], [nullId, tailId, headId]))
1304 , (reverseId, (AST.SubProgBody reverseSpec [AST.SPVD reverseVar] [reverseFor, reverseRet], []))
1307 ixPar = AST.unsafeVHDLBasicId "ix"
1308 vecPar = AST.unsafeVHDLBasicId "vec"
1309 vec1Par = AST.unsafeVHDLBasicId "vec1"
1310 vec2Par = AST.unsafeVHDLBasicId "vec2"
1311 nPar = AST.unsafeVHDLBasicId "n"
1312 leftPar = AST.unsafeVHDLBasicId "nLeft"
1313 rightPar = AST.unsafeVHDLBasicId "nRight"
1314 iId = AST.unsafeVHDLBasicId "i"
1316 aPar = AST.unsafeVHDLBasicId "a"
1317 fPar = AST.unsafeVHDLBasicId "f"
1318 sPar = AST.unsafeVHDLBasicId "s"
1319 resId = AST.unsafeVHDLBasicId "res"
1320 exSpec = AST.Function (mkVHDLExtId exId) [AST.IfaceVarDec vecPar vectorTM,
1321 AST.IfaceVarDec ixPar unsignedTM] elemTM
1322 exExpr = AST.ReturnSm (Just $ AST.PrimName $ AST.NIndexed
1323 (AST.IndexedName (AST.NSimple vecPar) [genExprFCall (mkVHDLBasicId toIntegerId) (AST.PrimName $ AST.NSimple ixPar)]))
1324 replaceSpec = AST.Function (mkVHDLExtId replaceId) [ AST.IfaceVarDec vecPar vectorTM
1325 , AST.IfaceVarDec iPar unsignedTM
1326 , AST.IfaceVarDec aPar elemTM
1328 -- variable res : fsvec_x (0 to vec'length-1);
1331 (AST.SubtypeIn vectorTM
1332 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1333 [AST.ToRange (AST.PrimLit "0")
1334 (AST.PrimName (AST.NAttribute $
1335 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1336 (AST.PrimLit "1")) ]))
1338 -- res AST.:= vec(0 to i-1) & a & vec(i+1 to length'vec-1)
1339 replaceExpr1 = AST.NSimple resId AST.:= AST.PrimName (AST.NSimple vecPar)
1340 replaceExpr2 = AST.NIndexed (AST.IndexedName (AST.NSimple resId) [genExprFCall (mkVHDLBasicId toIntegerId) (AST.PrimName $ AST.NSimple iPar)]) AST.:= AST.PrimName (AST.NSimple aPar)
1341 replaceRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1342 vecSlice init last = AST.PrimName (AST.NSlice
1344 (AST.NSimple vecPar)
1345 (AST.ToRange init last)))
1346 lastSpec = AST.Function (mkVHDLExtId lastId) [AST.IfaceVarDec vecPar vectorTM] elemTM
1347 -- return vec(vec'length-1);
1348 lastExpr = AST.ReturnSm (Just (AST.PrimName $ AST.NIndexed (AST.IndexedName
1349 (AST.NSimple vecPar)
1350 [AST.PrimName (AST.NAttribute $
1351 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing)
1352 AST.:-: AST.PrimLit "1"])))
1353 initSpec = AST.Function (mkVHDLExtId initId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
1354 -- variable res : fsvec_x (0 to vec'length-2);
1357 (AST.SubtypeIn vectorTM
1358 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1359 [AST.ToRange (AST.PrimLit "0")
1360 (AST.PrimName (AST.NAttribute $
1361 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1362 (AST.PrimLit "2")) ]))
1364 -- resAST.:= vec(0 to vec'length-2)
1365 initExpr = AST.NSimple resId AST.:= (vecSlice
1367 (AST.PrimName (AST.NAttribute $
1368 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing)
1369 AST.:-: AST.PrimLit "2"))
1370 initRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1371 minimumSpec = AST.Function (mkVHDLExtId minimumId) [AST.IfaceVarDec leftPar naturalTM,
1372 AST.IfaceVarDec rightPar naturalTM ] naturalTM
1373 minimumExpr = AST.IfSm ((AST.PrimName $ AST.NSimple leftPar) AST.:<: (AST.PrimName $ AST.NSimple rightPar))
1374 [AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple leftPar)]
1376 (Just $ AST.Else [minimumExprRet])
1377 where minimumExprRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple rightPar)
1378 takeSpec = AST.Function (mkVHDLExtId takeId) [AST.IfaceVarDec nPar naturalTM,
1379 AST.IfaceVarDec vecPar vectorTM ] vectorTM
1380 -- variable res : fsvec_x (0 to (minimum (n,vec'length))-1);
1381 minLength = AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId minimumId))
1382 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple nPar)
1383 ,Nothing AST.:=>: AST.ADExpr (AST.PrimName (AST.NAttribute $
1384 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))]
1387 (AST.SubtypeIn vectorTM
1388 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1389 [AST.ToRange (AST.PrimLit "0")
1391 (AST.PrimLit "1")) ]))
1393 -- res AST.:= vec(0 to n-1)
1394 takeExpr = AST.NSimple resId AST.:=
1395 (vecSlice (AST.PrimLit "0")
1396 (minLength AST.:-: AST.PrimLit "1"))
1397 takeRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1398 dropSpec = AST.Function (mkVHDLExtId dropId) [AST.IfaceVarDec nPar naturalTM,
1399 AST.IfaceVarDec vecPar vectorTM ] vectorTM
1400 -- variable res : fsvec_x (0 to vec'length-n-1);
1403 (AST.SubtypeIn vectorTM
1404 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1405 [AST.ToRange (AST.PrimLit "0")
1406 (AST.PrimName (AST.NAttribute $
1407 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1408 (AST.PrimName $ AST.NSimple nPar)AST.:-: (AST.PrimLit "1")) ]))
1410 -- res AST.:= vec(n to vec'length-1)
1411 dropExpr = AST.NSimple resId AST.:= (vecSlice
1412 (AST.PrimName $ AST.NSimple nPar)
1413 (AST.PrimName (AST.NAttribute $
1414 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing)
1415 AST.:-: AST.PrimLit "1"))
1416 dropRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1417 plusgtSpec = AST.Function (mkVHDLExtId plusgtId) [AST.IfaceVarDec aPar elemTM,
1418 AST.IfaceVarDec vecPar vectorTM] vectorTM
1419 -- variable res : fsvec_x (0 to vec'length);
1422 (AST.SubtypeIn vectorTM
1423 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1424 [AST.ToRange (AST.PrimLit "0")
1425 (AST.PrimName (AST.NAttribute $
1426 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))]))
1428 plusgtExpr = AST.NSimple resId AST.:=
1429 ((AST.PrimName $ AST.NSimple aPar) AST.:&:
1430 (AST.PrimName $ AST.NSimple vecPar))
1431 plusgtRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1432 emptySpec = AST.Function (mkVHDLExtId emptyId) [] vectorTM
1435 (AST.SubtypeIn vectorTM
1436 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1437 [AST.ToRange (AST.PrimLit "0") (AST.PrimLit "-1")]))
1439 emptyExpr = AST.ReturnSm (Just $ AST.PrimName (AST.NSimple resId))
1440 singletonSpec = AST.Function (mkVHDLExtId singletonId) [AST.IfaceVarDec aPar elemTM ]
1442 -- variable res : fsvec_x (0 to 0) := (others => a);
1445 (AST.SubtypeIn vectorTM
1446 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1447 [AST.ToRange (AST.PrimLit "0") (AST.PrimLit "0")]))
1448 (Just $ AST.Aggregate [AST.ElemAssoc (Just AST.Others)
1449 (AST.PrimName $ AST.NSimple aPar)])
1450 singletonRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1451 copynSpec = AST.Function (mkVHDLExtId copynId) [AST.IfaceVarDec nPar naturalTM,
1452 AST.IfaceVarDec aPar elemTM ] vectorTM
1453 -- variable res : fsvec_x (0 to n-1) := (others => a);
1456 (AST.SubtypeIn vectorTM
1457 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1458 [AST.ToRange (AST.PrimLit "0")
1459 ((AST.PrimName (AST.NSimple nPar)) AST.:-:
1460 (AST.PrimLit "1")) ]))
1461 (Just $ AST.Aggregate [AST.ElemAssoc (Just AST.Others)
1462 (AST.PrimName $ AST.NSimple aPar)])
1464 copynExpr = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1465 selSpec = AST.Function (mkVHDLExtId selId) [AST.IfaceVarDec fPar naturalTM,
1466 AST.IfaceVarDec sPar naturalTM,
1467 AST.IfaceVarDec nPar naturalTM,
1468 AST.IfaceVarDec vecPar vectorTM ] vectorTM
1469 -- variable res : fsvec_x (0 to n-1);
1472 (AST.SubtypeIn vectorTM
1473 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1474 [AST.ToRange (AST.PrimLit "0")
1475 ((AST.PrimName (AST.NSimple nPar)) AST.:-:
1476 (AST.PrimLit "1")) ])
1479 -- for i res'range loop
1480 -- res(i) := vec(f+i*s);
1482 selFor = AST.ForSM iId (AST.AttribRange $ AST.AttribName (AST.NSimple resId) (AST.NSimple rangeId) Nothing) [selAssign]
1483 -- res(i) := vec(f+i*s);
1484 selAssign = let origExp = AST.PrimName (AST.NSimple fPar) AST.:+:
1485 (AST.PrimName (AST.NSimple iId) AST.:*:
1486 AST.PrimName (AST.NSimple sPar)) in
1487 AST.NIndexed (AST.IndexedName (AST.NSimple resId) [AST.PrimName (AST.NSimple iId)]) AST.:=
1488 (AST.PrimName $ AST.NIndexed (AST.IndexedName (AST.NSimple vecPar) [origExp]))
1490 selRet = AST.ReturnSm (Just $ AST.PrimName (AST.NSimple resId))
1491 ltplusSpec = AST.Function (mkVHDLExtId ltplusId) [AST.IfaceVarDec vecPar vectorTM,
1492 AST.IfaceVarDec aPar elemTM] vectorTM
1493 -- variable res : fsvec_x (0 to vec'length);
1496 (AST.SubtypeIn vectorTM
1497 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1498 [AST.ToRange (AST.PrimLit "0")
1499 (AST.PrimName (AST.NAttribute $
1500 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))]))
1502 ltplusExpr = AST.NSimple resId AST.:=
1503 ((AST.PrimName $ AST.NSimple vecPar) AST.:&:
1504 (AST.PrimName $ AST.NSimple aPar))
1505 ltplusRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1506 plusplusSpec = AST.Function (mkVHDLExtId plusplusId) [AST.IfaceVarDec vec1Par vectorTM,
1507 AST.IfaceVarDec vec2Par vectorTM]
1509 -- variable res : fsvec_x (0 to vec1'length + vec2'length -1);
1512 (AST.SubtypeIn vectorTM
1513 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1514 [AST.ToRange (AST.PrimLit "0")
1515 (AST.PrimName (AST.NAttribute $
1516 AST.AttribName (AST.NSimple vec1Par) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:+:
1517 AST.PrimName (AST.NAttribute $
1518 AST.AttribName (AST.NSimple vec2Par) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1521 plusplusExpr = AST.NSimple resId AST.:=
1522 ((AST.PrimName $ AST.NSimple vec1Par) AST.:&:
1523 (AST.PrimName $ AST.NSimple vec2Par))
1524 plusplusRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1525 lengthTSpec = AST.Function (mkVHDLExtId lengthTId) [AST.IfaceVarDec vecPar vectorTM] naturalTM
1526 lengthTExpr = AST.ReturnSm (Just $ AST.PrimName (AST.NAttribute $
1527 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))
1528 shiftlSpec = AST.Function (mkVHDLExtId shiftIntoLId) [AST.IfaceVarDec vecPar vectorTM,
1529 AST.IfaceVarDec aPar elemTM ] vectorTM
1530 -- variable res : fsvec_x (0 to vec'length-1);
1533 (AST.SubtypeIn vectorTM
1534 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1535 [AST.ToRange (AST.PrimLit "0")
1536 (AST.PrimName (AST.NAttribute $
1537 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1538 (AST.PrimLit "1")) ]))
1540 -- res := a & init(vec)
1541 shiftlExpr = AST.NSimple resId AST.:=
1542 (AST.PrimName (AST.NSimple aPar) AST.:&:
1543 (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId initId))
1544 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]))
1545 shiftlRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1546 shiftrSpec = AST.Function (mkVHDLExtId shiftIntoRId) [AST.IfaceVarDec vecPar vectorTM,
1547 AST.IfaceVarDec aPar elemTM ] vectorTM
1548 -- variable res : fsvec_x (0 to vec'length-1);
1551 (AST.SubtypeIn vectorTM
1552 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1553 [AST.ToRange (AST.PrimLit "0")
1554 (AST.PrimName (AST.NAttribute $
1555 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1556 (AST.PrimLit "1")) ]))
1558 -- res := tail(vec) & a
1559 shiftrExpr = AST.NSimple resId AST.:=
1560 ((AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId tailId))
1561 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]) AST.:&:
1562 (AST.PrimName (AST.NSimple aPar)))
1564 shiftrRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1565 nullSpec = AST.Function (mkVHDLExtId nullId) [AST.IfaceVarDec vecPar vectorTM] booleanTM
1566 -- return vec'length = 0
1567 nullExpr = AST.ReturnSm (Just $
1568 AST.PrimName (AST.NAttribute $
1569 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:=:
1571 rotlSpec = AST.Function (mkVHDLExtId rotlId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
1572 -- variable res : fsvec_x (0 to vec'length-1);
1575 (AST.SubtypeIn vectorTM
1576 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1577 [AST.ToRange (AST.PrimLit "0")
1578 (AST.PrimName (AST.NAttribute $
1579 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1580 (AST.PrimLit "1")) ]))
1582 -- if null(vec) then res := vec else res := last(vec) & init(vec)
1583 rotlExpr = AST.IfSm (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId nullId))
1584 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)])
1585 [AST.NSimple resId AST.:= (AST.PrimName $ AST.NSimple vecPar)]
1587 (Just $ AST.Else [rotlExprRet])
1589 AST.NSimple resId AST.:=
1590 ((AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId lastId))
1591 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]) AST.:&:
1592 (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId initId))
1593 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]))
1594 rotlRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1595 rotrSpec = AST.Function (mkVHDLExtId rotrId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
1596 -- variable res : fsvec_x (0 to vec'length-1);
1599 (AST.SubtypeIn vectorTM
1600 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1601 [AST.ToRange (AST.PrimLit "0")
1602 (AST.PrimName (AST.NAttribute $
1603 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1604 (AST.PrimLit "1")) ]))
1606 -- if null(vec) then res := vec else res := tail(vec) & head(vec)
1607 rotrExpr = AST.IfSm (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId nullId))
1608 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)])
1609 [AST.NSimple resId AST.:= (AST.PrimName $ AST.NSimple vecPar)]
1611 (Just $ AST.Else [rotrExprRet])
1613 AST.NSimple resId AST.:=
1614 ((AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId tailId))
1615 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]) AST.:&:
1616 (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId headId))
1617 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]))
1618 rotrRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1619 reverseSpec = AST.Function (mkVHDLExtId reverseId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
1622 (AST.SubtypeIn vectorTM
1623 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1624 [AST.ToRange (AST.PrimLit "0")
1625 (AST.PrimName (AST.NAttribute $
1626 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1627 (AST.PrimLit "1")) ]))
1629 -- for i in 0 to res'range loop
1630 -- res(vec'length-i-1) := vec(i);
1633 AST.ForSM iId (AST.AttribRange $ AST.AttribName (AST.NSimple resId) (AST.NSimple rangeId) Nothing) [reverseAssign]
1634 -- res(vec'length-i-1) := vec(i);
1635 reverseAssign = AST.NIndexed (AST.IndexedName (AST.NSimple resId) [destExp]) AST.:=
1636 (AST.PrimName $ AST.NIndexed (AST.IndexedName (AST.NSimple vecPar)
1637 [AST.PrimName $ AST.NSimple iId]))
1638 where destExp = AST.PrimName (AST.NAttribute $ AST.AttribName (AST.NSimple vecPar)
1639 (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1640 AST.PrimName (AST.NSimple iId) AST.:-:
1643 reverseRet = AST.ReturnSm (Just $ AST.PrimName (AST.NSimple resId))
1646 -----------------------------------------------------------------------------
1647 -- A table of builtin functions
1648 -----------------------------------------------------------------------------
1650 -- A function that generates VHDL for a builtin function
1651 type BuiltinBuilder =
1652 (Either CoreSyn.CoreBndr AST.VHDLName) -- ^ The destination signal and it's original type
1653 -> CoreSyn.CoreBndr -- ^ The function called
1654 -> [(Either CoreSyn.CoreExpr AST.Expr, Type.Type)] -- ^ The value arguments passed (excluding type and
1655 -- dictionary arguments).
1656 -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
1657 -- ^ The corresponding VHDL concurrent statements and entities
1660 -- A map of a builtin function to VHDL function builder
1661 type NameTable = Map.Map String (Int, BuiltinBuilder )
1663 -- | The builtin functions we support. Maps a name to an argument count and a
1664 -- builder function. If you add a name to this map, don't forget to add
1665 -- it to VHDL.Constants/builtinIds as well.
1666 globalNameTable :: NameTable
1667 globalNameTable = Map.fromList
1668 [ (exId , (2, genFCall True ) )
1669 , (replaceId , (3, genFCall False ) )
1670 , (headId , (1, genFCall True ) )
1671 , (lastId , (1, genFCall True ) )
1672 , (tailId , (1, genFCall False ) )
1673 , (initId , (1, genFCall False ) )
1674 , (takeId , (2, genFCall False ) )
1675 , (dropId , (2, genFCall False ) )
1676 , (selId , (4, genFCall False ) )
1677 , (plusgtId , (2, genFCall False ) )
1678 , (ltplusId , (2, genFCall False ) )
1679 , (plusplusId , (2, genFCall False ) )
1680 , (mapId , (2, genMap ) )
1681 , (zipWithId , (3, genZipWith ) )
1682 , (foldlId , (3, genFoldl ) )
1683 , (foldrId , (3, genFoldr ) )
1684 , (zipId , (2, genZip ) )
1685 , (unzipId , (1, genUnzip ) )
1686 , (shiftIntoLId , (2, genFCall False ) )
1687 , (shiftIntoRId , (2, genFCall False ) )
1688 , (rotlId , (1, genFCall False ) )
1689 , (rotrId , (1, genFCall False ) )
1690 , (concatId , (1, genConcat ) )
1691 , (reverseId , (1, genFCall False ) )
1692 , (iteratenId , (3, genIteraten ) )
1693 , (iterateId , (2, genIterate ) )
1694 , (generatenId , (3, genGeneraten ) )
1695 , (generateId , (2, genGenerate ) )
1696 , (emptyId , (0, genFCall False ) )
1697 , (singletonId , (1, genFCall False ) )
1698 , (copynId , (2, genFCall False ) )
1699 , (copyId , (1, genCopy ) )
1700 , (lengthTId , (1, genFCall False ) )
1701 , (nullId , (1, genFCall False ) )
1702 , (hwxorId , (2, genOperator2 AST.Xor ) )
1703 , (hwandId , (2, genOperator2 AST.And ) )
1704 , (hworId , (2, genOperator2 AST.Or ) )
1705 , (hwnotId , (1, genOperator1 AST.Not ) )
1706 , (equalityId , (2, genOperator2 (AST.:=:) ) )
1707 , (inEqualityId , (2, genOperator2 (AST.:/=:) ) )
1708 , (ltId , (2, genOperator2 (AST.:<:) ) )
1709 , (lteqId , (2, genOperator2 (AST.:<=:) ) )
1710 , (gtId , (2, genOperator2 (AST.:>:) ) )
1711 , (gteqId , (2, genOperator2 (AST.:>=:) ) )
1712 , (boolOrId , (2, genOperator2 AST.Or ) )
1713 , (boolAndId , (2, genOperator2 AST.And ) )
1714 , (boolNot , (1, genOperator1 AST.Not ) )
1715 , (plusId , (2, genOperator2 (AST.:+:) ) )
1716 , (timesId , (2, genTimes ) )
1717 , (negateId , (1, genNegation ) )
1718 , (minusId , (2, genOperator2 (AST.:-:) ) )
1719 , (fromSizedWordId , (1, genFromSizedWord ) )
1720 , (fromRangedWordId , (1, genFromRangedWord ) )
1721 , (fromIntegerId , (1, genFromInteger ) )
1722 , (resizeWordId , (1, genResize ) )
1723 , (resizeIntId , (1, genResize ) )
1724 , (sizedIntId , (1, genSizedInt ) )
1725 , (smallIntegerId , (1, genFromInteger ) )
1726 , (fstId , (1, genFst ) )
1727 , (sndId , (1, genSnd ) )
1728 , (blockRAMId , (5, genBlockRAM ) )
1729 , (splitId , (1, genSplit ) )
1730 , (xorId , (2, genOperator2 AST.Xor ) )
1731 , (shiftLId , (2, genSll ) )
1732 , (shiftRId , (2, genSra ) )
1733 --, (tfvecId , (1, genTFVec ) )
1734 , (minimumId , (2, error "\nFunction name: \"minimum\" is used internally, use another name"))