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