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