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
25 import CLasH.Translator.TranslatorTypes
26 import CLasH.VHDL.Constants
27 import CLasH.VHDL.VHDLTypes
28 import CLasH.VHDL.VHDLTools
30 import CLasH.Utils.Core.CoreTools
31 import CLasH.Utils.Pretty
32 import qualified CLasH.Normalize as Normalize
34 -----------------------------------------------------------------------------
35 -- Functions to generate VHDL for user-defined functions.
36 -----------------------------------------------------------------------------
38 -- | Create an entity for a given function
41 -> TranslatorSession Entity -- ^ The resulting entity
43 getEntity fname = makeCached fname tsEntities $ do
44 expr <- Normalize.getNormalized False fname
45 -- Split the normalized expression
46 let (args, binds, res) = Normalize.splitNormalized expr
47 -- Generate ports for all non-empty types
48 args' <- catMaybesM $ mapM mkMap args
49 -- TODO: Handle Nothing
51 count <- MonadState.get tsEntityCounter
52 let vhdl_id = mkVHDLBasicId $ varToString fname ++ "Component_" ++ show count
53 MonadState.set tsEntityCounter (count + 1)
54 let ent_decl = createEntityAST vhdl_id args' res'
55 let signature = Entity vhdl_id args' res' ent_decl
59 --[(SignalId, SignalInfo)]
61 -> TranslatorSession (Maybe Port)
64 --info = Maybe.fromMaybe
65 -- (error $ "Signal not found in the name map? This should not happen!")
67 -- Assume the bndr has a valid VHDL id already
70 error_msg = "\nVHDL.createEntity.mkMap: Can not create entity: " ++ pprString fname ++ "\nbecause no type can be created for port: " ++ pprString bndr
72 type_mark_maybe <- MonadState.lift tsType $ vhdlTy error_msg ty
73 case type_mark_maybe of
74 Just type_mark -> return $ Just (id, type_mark)
75 Nothing -> return Nothing
78 -- | Create the VHDL AST for an entity
80 AST.VHDLId -- ^ The name of the function
81 -> [Port] -- ^ The entity's arguments
82 -> Maybe Port -- ^ The entity's result
83 -> AST.EntityDec -- ^ The entity with the ent_decl filled in as well
85 createEntityAST vhdl_id args res =
86 AST.EntityDec vhdl_id ports
88 -- Create a basic Id, since VHDL doesn't grok filenames with extended Ids.
89 ports = map (mkIfaceSigDec AST.In) args
90 ++ (Maybe.maybeToList res_port)
91 ++ [clk_port,resetn_port]
92 -- Add a clk port if we have state
93 clk_port = AST.IfaceSigDec clockId AST.In std_logicTM
94 resetn_port = AST.IfaceSigDec resetId AST.In std_logicTM
95 res_port = fmap (mkIfaceSigDec AST.Out) res
97 -- | Create a port declaration
99 AST.Mode -- ^ The mode for the port (In / Out)
100 -> Port -- ^ The id and type for the port
101 -> AST.IfaceSigDec -- ^ The resulting port declaration
103 mkIfaceSigDec mode (id, ty) = AST.IfaceSigDec id mode ty
105 -- | Create an architecture for a given function
107 CoreSyn.CoreBndr -- ^ The function to get an architecture for
108 -> TranslatorSession (Architecture, [CoreSyn.CoreBndr])
109 -- ^ The architecture for this function
111 getArchitecture fname = makeCached fname tsArchitectures $ do
112 expr <- Normalize.getNormalized False fname
113 -- Split the normalized expression
114 let (args, binds, res) = Normalize.splitNormalized expr
116 -- Get the entity for this function
117 signature <- getEntity fname
118 let entity_id = ent_id signature
120 -- Create signal declarations for all binders in the let expression, except
121 -- for the output port (that will already have an output port declared in
123 sig_dec_maybes <- mapM (mkSigDec . fst) (filter ((/=res).fst) binds)
124 let sig_decs = Maybe.catMaybes sig_dec_maybes
125 -- Process each bind, resulting in info about state variables and concurrent
127 (state_vars, sms) <- Monad.mapAndUnzipM dobind binds
128 let (in_state_maybes, out_state_maybes) = unzip state_vars
129 let (statementss, used_entitiess) = unzip sms
130 -- Get initial state, if it's there
131 initSmap <- MonadState.get tsInitStates
132 let init_state = Map.lookup fname initSmap
133 -- Create a state proc, if needed
134 (state_proc, resbndr) <- case (Maybe.catMaybes in_state_maybes, Maybe.catMaybes out_state_maybes, init_state) of
135 ([in_state], [out_state], Nothing) -> do
136 nonEmpty <- hasNonEmptyType in_state
138 then error ("No initial state defined for: " ++ show fname)
140 ([in_state], [out_state], Just resetval) -> do
141 nonEmpty <- hasNonEmptyType in_state
143 then mkStateProcSm (in_state, out_state, resetval)
144 else error ("Initial state defined for function with only substate: " ++ show fname)
145 ([], [], Just _) -> error $ "Initial state defined for state-less function: " ++ show fname
146 ([], [], Nothing) -> return ([],[])
147 (ins, outs, res) -> error $ "Weird use of state in " ++ show fname ++ ". In: " ++ show ins ++ " Out: " ++ show outs
148 -- Join the create statements and the (optional) state_proc
149 let statements = concat statementss ++ state_proc
150 -- Create the architecture
151 let arch = AST.ArchBody (mkVHDLBasicId "structural") (AST.NSimple entity_id) (map AST.BDISD sig_decs) statements
152 let used_entities = (concat used_entitiess) ++ resbndr
153 return (arch, used_entities)
155 dobind :: (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The bind to process
156 -> TranslatorSession ((Maybe CoreSyn.CoreBndr, Maybe CoreSyn.CoreBndr), ([AST.ConcSm], [CoreSyn.CoreBndr]))
157 -- ^ ((Input state variable, output state variable), (statements, used entities))
158 -- newtype unpacking is just a cast
159 dobind (bndr, unpacked@(CoreSyn.Cast packed coercion))
160 | hasStateType packed && not (hasStateType unpacked)
161 = return ((Just bndr, Nothing), ([], []))
162 -- With simplCore, newtype packing is just a cast
163 dobind (bndr, packed@(CoreSyn.Cast unpacked@(CoreSyn.Var state) coercion))
164 | hasStateType packed && not (hasStateType unpacked)
165 = return ((Nothing, Just state), ([], []))
166 -- Without simplCore, newtype packing uses a data constructor
167 dobind (bndr, (CoreSyn.App (CoreSyn.App (CoreSyn.Var con) (CoreSyn.Type _)) (CoreSyn.Var state)))
169 = return ((Nothing, Just state), ([], []))
170 -- Anything else is handled by mkConcSm
173 return ((Nothing, Nothing), sms)
176 (CoreSyn.CoreBndr, CoreSyn.CoreBndr, CoreSyn.CoreBndr) -- ^ The current state, new state and reset variables
177 -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr]) -- ^ The resulting statements
178 mkStateProcSm (old, new, res) = do
179 let error_msg = "\nVHDL.mkSigDec: Can not make signal declaration for type: \n" ++ pprString res
180 type_mark_old_maybe <- MonadState.lift tsType $ vhdlTy error_msg (Var.varType old)
181 let type_mark_old = Maybe.fromMaybe
182 (error $ "\nGenerate.mkStateProcSm: empty type for state? Type: " ++ pprString (Var.varType old))
184 type_mark_res_maybe <- MonadState.lift tsType $ vhdlTy error_msg (Var.varType res)
185 let type_mark_res' = Maybe.fromMaybe
186 (error $ "\nGenerate.mkStateProcSm: empty type for initial state? Type: " ++ pprString (Var.varType res))
188 let type_mark_res = if type_mark_old == type_mark_res' then
191 error $ "Initial state has different type than state type, state type: " ++ show type_mark_old ++ ", init type: " ++ show type_mark_res'
192 let resvalid = mkVHDLExtId $ varToString res ++ "val"
193 let resvaldec = AST.BDISD $ AST.SigDec resvalid type_mark_res Nothing
194 let reswform = AST.Wform [AST.WformElem (AST.PrimName $ AST.NSimple resvalid) Nothing]
195 let res_assign = AST.SigAssign (varToVHDLName old) reswform
196 let blocklabel = mkVHDLBasicId "state"
197 let statelabel = mkVHDLBasicId "stateupdate"
198 let rising_edge = AST.NSimple $ mkVHDLBasicId "rising_edge"
199 let wform = AST.Wform [AST.WformElem (AST.PrimName $ varToVHDLName new) Nothing]
200 let clk_assign = AST.SigAssign (varToVHDLName old) wform
201 let rising_edge_clk = AST.PrimFCall $ AST.FCall rising_edge [Nothing AST.:=>: (AST.ADName $ AST.NSimple clockId)]
202 let resetn_is_low = (AST.PrimName $ AST.NSimple resetId) AST.:=: (AST.PrimLit "'0'")
203 signature <- getEntity res
204 let entity_id = ent_id signature
205 let reslabel = "resetval_" ++ ((prettyShow . varToVHDLName) res)
206 let portmaps = mkAssocElems [] (AST.NSimple resvalid) signature
207 let reset_statement = mkComponentInst reslabel entity_id portmaps
208 let clk_statement = [AST.ElseIf rising_edge_clk [clk_assign]]
209 let statement = AST.IfSm resetn_is_low [res_assign] clk_statement Nothing
210 let stateupdate = AST.CSPSm $ AST.ProcSm statelabel [clockId,resetId,resvalid] [statement]
211 let block = AST.CSBSm $ AST.BlockSm blocklabel [] (AST.PMapAspect []) [resvaldec] [reset_statement,stateupdate]
212 return ([block],[res])
214 -- | Transforms a core binding into a VHDL concurrent statement
216 (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The binding to process
217 -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
218 -- ^ The corresponding VHDL concurrent statements and entities
222 -- Ignore Cast expressions, they should not longer have any meaning as long as
223 -- the type works out. Throw away state repacking
224 mkConcSm (bndr, to@(CoreSyn.Cast from ty))
225 | hasStateType to && hasStateType from
227 mkConcSm (bndr, CoreSyn.Cast expr ty) = mkConcSm (bndr, expr)
229 -- Simple a = b assignments are just like applications, but without arguments.
230 -- We can't just generate an unconditional assignment here, since b might be a
231 -- top level binding (e.g., a function with no arguments).
232 mkConcSm (bndr, CoreSyn.Var v) =
233 genApplication (Left bndr) v []
235 mkConcSm (bndr, app@(CoreSyn.App _ _))= do
236 let (CoreSyn.Var f, args) = CoreSyn.collectArgs app
237 let valargs = get_val_args (Var.varType f) args
238 genApplication (Left bndr) f (map Left valargs)
240 -- A single alt case must be a selector. This means the scrutinee is a simple
241 -- variable, the alternative is a dataalt with a single non-wild binder that
243 mkConcSm (bndr, expr@(CoreSyn.Case (CoreSyn.Var scrut) b ty [alt]))
244 -- Don't generate VHDL for substate extraction
245 | hasStateType bndr = return ([], [])
248 (CoreSyn.DataAlt dc, bndrs, (CoreSyn.Var sel_bndr)) -> do
249 nonemptysel <- hasNonEmptyType sel_bndr
252 bndrs' <- Monad.filterM hasNonEmptyType bndrs
253 case List.elemIndex sel_bndr bndrs' of
255 htypeScrt <- MonadState.lift tsType $ mkHTypeEither (Var.varType scrut)
256 htypeBndr <- MonadState.lift tsType $ mkHTypeEither (Var.varType bndr)
257 case htypeScrt == htypeBndr of
259 let sel_name = varToVHDLName scrut
260 let sel_expr = AST.PrimName sel_name
261 return ([mkUncondAssign (Left bndr) sel_expr], [])
264 Right (AggrType _ _) -> do
265 labels <- MonadState.lift tsType $ getFieldLabels (Id.idType scrut)
266 let label = labels!!i
267 let sel_name = mkSelectedName (varToVHDLName scrut) label
268 let sel_expr = AST.PrimName sel_name
269 return ([mkUncondAssign (Left bndr) sel_expr], [])
270 _ -> do -- error $ "DIE!"
271 let sel_name = varToVHDLName scrut
272 let sel_expr = AST.PrimName sel_name
273 return ([mkUncondAssign (Left bndr) sel_expr], [])
274 Nothing -> error $ "\nVHDL.mkConcSM: Not in normal form: Not a selector case: result is not one of the binders\n" ++ (pprString expr)
276 -- A selector case that selects a state value, ignore it.
279 _ -> error $ "\nVHDL.mkConcSM: Not in normal form: Not a selector case:\n" ++ (pprString expr)
281 -- Multiple case alt are be conditional assignments and have only wild
282 -- binders in the alts and only variables in the case values and a variable
283 -- for a scrutinee. We check the constructor of the second alt, since the
284 -- first is the default case, if there is any.
286 -- mkConcSm (bndr, (CoreSyn.Case (CoreSyn.Var scrut) b ty [(_, _, CoreSyn.Var false), (con, _, CoreSyn.Var true)])) = do
287 -- scrut' <- MonadState.lift tsType $ varToVHDLExpr scrut
288 -- altcon <- MonadState.lift tsType $ altconToVHDLExpr con
289 -- let cond_expr = scrut' AST.:=: altcon
290 -- true_expr <- MonadState.lift tsType $ varToVHDLExpr true
291 -- false_expr <- MonadState.lift tsType $ varToVHDLExpr false
292 -- return ([mkCondAssign (Left bndr) cond_expr true_expr false_expr], [])
293 mkConcSm (bndr, (CoreSyn.Case (CoreSyn.Var scrut) _ _ (alt:alts))) = do --error "\nVHDL.mkConcSm: Not in normal form: Case statement with more than two alternatives"
294 scrut' <- MonadState.lift tsType $ varToVHDLExpr scrut
295 -- Omit first condition, which is the default
296 altcons <- MonadState.lift tsType $ mapM (altconToVHDLExpr . (\(con,_,_) -> con)) alts
297 let cond_exprs = map (\x -> scrut' AST.:=: x) altcons
298 -- Rotate expressions to the left, so that the expression related to the default case is the last
299 exprs <- MonadState.lift tsType $ mapM (varToVHDLExpr . (\(_,_,CoreSyn.Var expr) -> expr)) (alts ++ [alt])
300 return ([mkAltsAssign (Left bndr) cond_exprs exprs], [])
302 mkConcSm (_, CoreSyn.Case _ _ _ _) = error "\nVHDL.mkConcSm: Not in normal form: Case statement does not have a simple variable as scrutinee"
303 mkConcSm (bndr, expr) = error $ "\nVHDL.mkConcSM: Unsupported binding in let expression: " ++ pprString bndr ++ " = " ++ pprString expr
305 -----------------------------------------------------------------------------
306 -- Functions to generate VHDL for builtin functions
307 -----------------------------------------------------------------------------
309 -- | A function to wrap a builder-like function that expects its arguments to
311 genExprArgs wrap dst func args = do
312 args' <- argsToVHDLExprs args
315 -- | Turn the all lefts into VHDL Expressions.
316 argsToVHDLExprs :: [Either CoreSyn.CoreExpr AST.Expr] -> TranslatorSession [AST.Expr]
317 argsToVHDLExprs = catMaybesM . (mapM argToVHDLExpr)
319 argToVHDLExpr :: Either CoreSyn.CoreExpr AST.Expr -> TranslatorSession (Maybe AST.Expr)
320 argToVHDLExpr (Left expr) = MonadState.lift tsType $ do
321 let errmsg = "Generate.argToVHDLExpr: Using non-representable type? Should not happen!"
322 ty_maybe <- vhdlTy errmsg expr
325 vhdl_expr <- varToVHDLExpr $ exprToVar expr
326 return $ Just vhdl_expr
327 Nothing -> return Nothing
329 argToVHDLExpr (Right expr) = return $ Just expr
331 -- A function to wrap a builder-like function that generates no component
334 (dst -> func -> args -> TranslatorSession [AST.ConcSm])
335 -> (dst -> func -> args -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr]))
336 genNoInsts wrap dst func args = do
337 concsms <- wrap dst func args
340 -- | A function to wrap a builder-like function that expects its arguments to
343 (dst -> func -> [Var.Var] -> res)
344 -> (dst -> func -> [Either CoreSyn.CoreExpr AST.Expr] -> res)
345 genVarArgs wrap = genCoreArgs $ \dst func args -> let
346 args' = map exprToVar args
350 -- | A function to wrap a builder-like function that expects its arguments to
351 -- be core expressions.
353 (dst -> func -> [CoreSyn.CoreExpr] -> res)
354 -> (dst -> func -> [Either CoreSyn.CoreExpr AST.Expr] -> res)
355 genCoreArgs wrap dst func args = wrap dst func args'
357 -- Check (rather crudely) that all arguments are CoreExprs
358 args' = case Either.partitionEithers args of
359 (exprargs, []) -> exprargs
360 (exprsargs, rest) -> error $ "\nGenerate.genCoreArgs: expect core expression arguments but found ast exprs:" ++ (show rest)
362 -- | A function to wrap a builder-like function that produces an expression
363 -- and expects it to be assigned to the destination.
365 ((Either CoreSyn.CoreBndr AST.VHDLName) -> func -> [arg] -> TranslatorSession AST.Expr)
366 -> ((Either CoreSyn.CoreBndr AST.VHDLName) -> func -> [arg] -> TranslatorSession [AST.ConcSm])
367 genExprRes wrap dst func args = do
368 expr <- wrap dst func args
369 return [mkUncondAssign dst expr]
371 -- | Generate a binary operator application. The first argument should be a
372 -- constructor from the AST.Expr type, e.g. AST.And.
373 genOperator2 :: (AST.Expr -> AST.Expr -> AST.Expr) -> BuiltinBuilder
374 genOperator2 op = genNoInsts $ genExprArgs $ genExprRes (genOperator2' op)
375 genOperator2' :: (AST.Expr -> AST.Expr -> AST.Expr) -> dst -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession AST.Expr
376 genOperator2' op _ f [arg1, arg2] = return $ op arg1 arg2
378 -- | Generate a unary operator application
379 genOperator1 :: (AST.Expr -> AST.Expr) -> BuiltinBuilder
380 genOperator1 op = genNoInsts $ genExprArgs $ genExprRes (genOperator1' op)
381 genOperator1' :: (AST.Expr -> AST.Expr) -> dst -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession AST.Expr
382 genOperator1' op _ f [arg] = return $ op arg
384 -- | Generate a unary operator application
385 genNegation :: BuiltinBuilder
386 genNegation = genNoInsts $ genVarArgs $ genExprRes genNegation'
387 genNegation' :: dst -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession AST.Expr
388 genNegation' _ f [arg] = do
389 arg1 <- MonadState.lift tsType $ varToVHDLExpr arg
390 let ty = Var.varType arg
391 let (tycon, args) = Type.splitTyConApp ty
392 let name = Name.getOccString (TyCon.tyConName tycon)
394 "SizedInt" -> return $ AST.Neg arg1
395 otherwise -> error $ "\nGenerate.genNegation': Negation not allowed for type: " ++ show name
397 -- | Generate a function call from the destination binder, function name and a
398 -- list of expressions (its arguments)
399 genFCall :: Bool -> BuiltinBuilder
400 genFCall switch = genNoInsts $ genExprArgs $ genExprRes (genFCall' switch)
401 genFCall' :: Bool -> Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession AST.Expr
402 genFCall' switch (Left res) f args = do
403 let fname = varToString f
404 let el_ty = if switch then (Var.varType res) else ((tfvec_elem . Var.varType) res)
405 id <- MonadState.lift tsType $ vectorFunId el_ty fname
406 return $ AST.PrimFCall $ AST.FCall (AST.NSimple id) $
407 map (\exp -> Nothing AST.:=>: AST.ADExpr exp) args
408 genFCall' _ (Right name) _ _ = error $ "\nGenerate.genFCall': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
410 genFromSizedWord :: BuiltinBuilder
411 genFromSizedWord = genNoInsts $ genExprArgs genFromSizedWord'
412 genFromSizedWord' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession [AST.ConcSm]
413 genFromSizedWord' (Left res) f args@[arg] =
414 return [mkUncondAssign (Left res) arg]
415 -- let fname = varToString f
416 -- return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId toIntegerId)) $
417 -- map (\exp -> Nothing AST.:=>: AST.ADExpr exp) args
418 genFromSizedWord' (Right name) _ _ = error $ "\nGenerate.genFromSizedWord': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
420 genFromRangedWord :: BuiltinBuilder
421 genFromRangedWord = genNoInsts $ genExprArgs $ genExprRes genFromRangedWord'
422 genFromRangedWord' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession AST.Expr
423 genFromRangedWord' (Left res) f [arg] = do {
424 ; let { ty = Var.varType res
425 ; (tycon, args) = Type.splitTyConApp ty
426 ; name = Name.getOccString (TyCon.tyConName tycon)
428 ; len <- MonadState.lift tsType $ tfp_to_int (sized_word_len_ty ty)
429 ; return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId resizeId))
430 [Nothing AST.:=>: AST.ADExpr arg, Nothing AST.:=>: AST.ADExpr( AST.PrimLit (show len))]
432 genFromRangedWord' (Right name) _ _ = error $ "\nGenerate.genFromRangedWord': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
434 genResize :: BuiltinBuilder
435 genResize = genNoInsts $ genExprArgs $ genExprRes genResize'
436 genResize' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession AST.Expr
437 genResize' (Left res) f [arg] = do {
438 ; let { ty = Var.varType res
439 ; (tycon, args) = Type.splitTyConApp ty
440 ; name = Name.getOccString (TyCon.tyConName tycon)
442 ; len <- case name of
443 "SizedInt" -> MonadState.lift tsType $ tfp_to_int (sized_int_len_ty ty)
444 "SizedWord" -> MonadState.lift tsType $ tfp_to_int (sized_word_len_ty ty)
445 ; return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId resizeId))
446 [Nothing AST.:=>: AST.ADExpr arg, Nothing AST.:=>: AST.ADExpr( AST.PrimLit (show len))]
448 genResize' (Right name) _ _ = error $ "\nGenerate.genFromSizedWord': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
450 genTimes :: BuiltinBuilder
451 genTimes = genNoInsts $ genExprArgs $ genExprRes genTimes'
452 genTimes' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession AST.Expr
453 genTimes' (Left res) f [arg1,arg2] = do {
454 ; let { ty = Var.varType res
455 ; (tycon, args) = Type.splitTyConApp ty
456 ; name = Name.getOccString (TyCon.tyConName tycon)
458 ; len <- case name of
459 "SizedInt" -> MonadState.lift tsType $ tfp_to_int (sized_int_len_ty ty)
460 "SizedWord" -> MonadState.lift tsType $ tfp_to_int (sized_word_len_ty ty)
461 "RangedWord" -> do { ubound <- MonadState.lift tsType $ tfp_to_int (ranged_word_bound_ty ty)
462 ; let bitsize = floor (logBase 2 (fromInteger (toInteger ubound)))
465 ; return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId resizeId))
466 [Nothing AST.:=>: AST.ADExpr (arg1 AST.:*: arg2), Nothing AST.:=>: AST.ADExpr( AST.PrimLit (show len))]
468 genTimes' (Right name) _ _ = error $ "\nGenerate.genTimes': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
470 -- fromInteger turns an Integer into a Num instance. Since Integer is
471 -- not representable and is only allowed for literals, the actual
472 -- Integer should be inlined entirely into the fromInteger argument.
473 genFromInteger :: BuiltinBuilder
474 genFromInteger = genNoInsts $ genCoreArgs $ genExprRes genFromInteger'
475 genFromInteger' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [CoreSyn.CoreExpr] -> TranslatorSession AST.Expr
476 genFromInteger' (Left res) f args = do
477 let ty = Var.varType res
478 let (tycon, tyargs) = Type.splitTyConApp ty
479 let name = Name.getOccString (TyCon.tyConName tycon)
481 "SizedInt" -> MonadState.lift tsType $ tfp_to_int (sized_int_len_ty ty)
482 "SizedWord" -> MonadState.lift tsType $ tfp_to_int (sized_word_len_ty ty)
484 bound <- MonadState.lift tsType $ tfp_to_int (ranged_word_bound_ty ty)
485 return $ floor (logBase 2 (fromInteger (toInteger (bound)))) + 1
486 let fname = case name of "SizedInt" -> toSignedId ; "SizedWord" -> toUnsignedId ; "RangedWord" -> toUnsignedId
488 [integer] -> do -- The type and dictionary arguments are removed by genApplication
489 literal <- getIntegerLiteral integer
490 return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId fname))
491 [Nothing AST.:=>: AST.ADExpr (AST.PrimLit (show literal)), Nothing AST.:=>: AST.ADExpr( AST.PrimLit (show len))]
492 _ -> error $ "\nGenerate.genFromInteger': Wrong number of arguments to genInteger. Applying " ++ pprString f ++ " to " ++ pprString args
494 genFromInteger' (Right name) _ _ = error $ "\nGenerate.genFromInteger': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
496 genSizedInt :: BuiltinBuilder
497 genSizedInt = genFromInteger
500 -- | Generate a Builder for the builtin datacon TFVec
501 genTFVec :: BuiltinBuilder
502 genTFVec (Left res) f [Left (CoreSyn.Let (CoreSyn.Rec letBinders) letRes)] = do {
503 -- Generate Assignments for all the binders
504 ; letAssigns <- mapM genBinderAssign letBinders
505 -- Generate assignments for the result (which might be another let binding)
506 ; (resBinders,resAssignments) <- genResAssign letRes
507 -- Get all the Assigned binders
508 ; let assignedBinders = Maybe.catMaybes (map fst letAssigns)
509 -- Make signal names for all the assigned binders
510 ; sigs <- mapM (\x -> MonadState.lift tsType $ varToVHDLExpr x) (assignedBinders ++ resBinders)
511 -- Assign all the signals to the resulting vector
512 ; let { vecsigns = mkAggregateSignal sigs
513 ; vecassign = mkUncondAssign (Left res) vecsigns
515 -- Generate all the signal declaration for the assigned binders
516 ; sig_dec_maybes <- mapM mkSigDec (assignedBinders ++ resBinders)
517 ; let { sig_decs = map (AST.BDISD) (Maybe.catMaybes $ sig_dec_maybes)
518 -- Setup the VHDL Block
519 ; block_label = mkVHDLExtId ("TFVec_" ++ show (varToString res))
520 ; block = AST.BlockSm block_label [] (AST.PMapAspect []) sig_decs ((concat (map snd letAssigns)) ++ resAssignments ++ [vecassign])
522 -- Return the block statement coressponding to the TFVec literal
523 ; return $ [AST.CSBSm block]
526 genBinderAssign :: (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -> TranslatorSession (Maybe CoreSyn.CoreBndr, [AST.ConcSm])
527 -- For now we only translate applications
528 genBinderAssign (bndr, app@(CoreSyn.App _ _)) = do
529 let (CoreSyn.Var f, args) = CoreSyn.collectArgs app
530 let valargs = get_val_args (Var.varType f) args
531 apps <- genApplication (Left bndr) f (map Left valargs)
532 return (Just bndr, apps)
533 genBinderAssign _ = return (Nothing,[])
534 genResAssign :: CoreSyn.CoreExpr -> TranslatorSession ([CoreSyn.CoreBndr], [AST.ConcSm])
535 genResAssign app@(CoreSyn.App _ letexpr) = do
537 (CoreSyn.Let (CoreSyn.Rec letbndrs) letres) -> do
538 letapps <- mapM genBinderAssign letbndrs
539 let bndrs = Maybe.catMaybes (map fst letapps)
540 let app = (map snd letapps)
541 (vars, apps) <- genResAssign letres
542 return ((bndrs ++ vars),((concat app) ++ apps))
543 otherwise -> return ([],[])
544 genResAssign _ = return ([],[])
546 genTFVec (Left res) f [Left app@(CoreSyn.App _ _)] = do {
547 ; let { elems = reduceCoreListToHsList app
548 -- Make signal names for all the binders
549 ; binders = map (\expr -> case expr of
551 otherwise -> error $ "\nGenerate.genTFVec: Cannot generate TFVec: "
552 ++ show res ++ ", with elems:\n" ++ show elems ++ "\n" ++ pprString elems) elems
554 ; sigs <- mapM (\x -> MonadState.lift tsType $ varToVHDLExpr x) binders
555 -- Assign all the signals to the resulting vector
556 ; let { vecsigns = mkAggregateSignal sigs
557 ; vecassign = mkUncondAssign (Left res) vecsigns
558 -- Setup the VHDL Block
559 ; block_label = mkVHDLExtId ("TFVec_" ++ show (varToString res))
560 ; block = AST.BlockSm block_label [] (AST.PMapAspect []) [] [vecassign]
562 -- Return the block statement coressponding to the TFVec literal
563 ; return $ [AST.CSBSm block]
566 genTFVec (Left name) _ [Left xs] = error $ "\nGenerate.genTFVec: Cannot generate TFVec: " ++ show name ++ ", with elems:\n" ++ show xs ++ "\n" ++ pprString xs
568 genTFVec (Right name) _ _ = error $ "\nGenerate.genTFVec: Cannot generate TFVec assigned to VHDLName: " ++ show name
570 -- | Generate a generate statement for the builtin function "map"
571 genMap :: BuiltinBuilder
572 genMap (Left res) f [Left mapped_f, Left (CoreSyn.Var arg)] = do {
573 -- mapped_f must be a CoreExpr (since we can't represent functions as VHDL
574 -- expressions). arg must be a CoreExpr (and should be a CoreSyn.Var), since
575 -- we must index it (which we couldn't if it was a VHDL Expr, since only
576 -- VHDLNames can be indexed).
577 -- Setup the generate scheme
578 ; len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) res
579 -- TODO: Use something better than varToString
580 ; let { label = mkVHDLExtId ("mapVector" ++ (varToString res))
581 ; n_id = mkVHDLBasicId "n"
582 ; n_expr = idToVHDLExpr n_id
583 ; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
584 ; genScheme = AST.ForGn n_id range
585 -- Create the content of the generate statement: Applying the mapped_f to
586 -- each of the elements in arg, storing to each element in res
587 ; resname = mkIndexedName (varToVHDLName res) n_expr
588 ; argexpr = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg) n_expr
589 ; (CoreSyn.Var real_f, already_mapped_args) = CoreSyn.collectArgs mapped_f
590 ; valargs = get_val_args (Var.varType real_f) already_mapped_args
592 ; (app_concsms, used) <- genApplication (Right resname) real_f (map Left valargs ++ [Right argexpr])
593 -- Return the generate statement
594 ; return ([AST.CSGSm $ AST.GenerateSm label genScheme [] app_concsms], used)
597 genMap' (Right name) _ _ = error $ "\nGenerate.genMap': Cannot generate map function call assigned to a VHDLName: " ++ show name
599 genZipWith :: BuiltinBuilder
600 genZipWith (Left res) f args@[Left zipped_f, Left (CoreSyn.Var arg1), Left (CoreSyn.Var arg2)] = do {
601 -- Setup the generate scheme
602 ; len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) res
603 -- TODO: Use something better than varToString
604 ; let { label = mkVHDLExtId ("zipWithVector" ++ (varToString res))
605 ; n_id = mkVHDLBasicId "n"
606 ; n_expr = idToVHDLExpr n_id
607 ; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
608 ; genScheme = AST.ForGn n_id range
609 -- Create the content of the generate statement: Applying the zipped_f to
610 -- each of the elements in arg1 and arg2, storing to each element in res
611 ; resname = mkIndexedName (varToVHDLName res) n_expr
612 ; (CoreSyn.Var real_f, already_mapped_args) = CoreSyn.collectArgs zipped_f
613 ; valargs = get_val_args (Var.varType real_f) already_mapped_args
614 ; argexpr1 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg1) n_expr
615 ; argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg2) n_expr
617 ; (app_concsms, used) <- genApplication (Right resname) real_f (map Left valargs ++ [Right argexpr1, Right argexpr2])
618 -- Return the generate functions
619 ; return ([AST.CSGSm $ AST.GenerateSm label genScheme [] app_concsms], used)
622 genFoldl :: BuiltinBuilder
623 genFoldl = genFold True
625 genFoldr :: BuiltinBuilder
626 genFoldr = genFold False
628 genFold :: Bool -> BuiltinBuilder
629 genFold left = genVarArgs (genFold' left)
631 genFold' :: Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
632 genFold' left res f args@[folded_f , start ,vec]= do
633 len <- MonadState.lift tsType $ tfp_to_int (tfvec_len_ty (Var.varType vec))
634 genFold'' len left res f args
636 genFold'' :: Int -> Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
637 -- Special case for an empty input vector, just assign start to res
638 genFold'' len left (Left res) _ [_, start, vec] | len == 0 = do
639 arg <- MonadState.lift tsType $ varToVHDLExpr start
640 return ([mkUncondAssign (Left res) arg], [])
642 genFold'' len left (Left res) f [folded_f, start, vec] = do
644 --len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) vec
645 -- An expression for len-1
646 let len_min_expr = (AST.PrimLit $ show (len-1))
647 -- evec is (TFVec n), so it still needs an element type
648 let (nvec, _) = Type.splitAppTy (Var.varType vec)
649 -- Put the type of the start value in nvec, this will be the type of our
651 let tmp_ty = Type.mkAppTy nvec (Var.varType start)
652 let error_msg = "\nGenerate.genFold': Can not construct temp vector for element type: " ++ pprString tmp_ty
653 -- TODO: Handle Nothing
654 Just tmp_vhdl_ty <- MonadState.lift tsType $ vhdlTy error_msg tmp_ty
655 -- Setup the generate scheme
656 let gen_label = mkVHDLExtId ("foldlVector" ++ (varToString vec))
657 let block_label = mkVHDLExtId ("foldlVector" ++ (varToString res))
658 let gen_range = if left then AST.ToRange (AST.PrimLit "0") len_min_expr
659 else AST.DownRange len_min_expr (AST.PrimLit "0")
660 let gen_scheme = AST.ForGn n_id gen_range
661 -- Make the intermediate vector
662 let tmp_dec = AST.BDISD $ AST.SigDec tmp_id tmp_vhdl_ty Nothing
663 -- Create the generate statement
664 cells' <- sequence [genFirstCell, genOtherCell]
665 let (cells, useds) = unzip cells'
666 let gen_sm = AST.GenerateSm gen_label gen_scheme [] (map AST.CSGSm cells)
667 -- Assign tmp[len-1] or tmp[0] to res
668 let out_assign = mkUncondAssign (Left res) $ vhdlNameToVHDLExpr (if left then
669 (mkIndexedName tmp_name (AST.PrimLit $ show (len-1))) else
670 (mkIndexedName tmp_name (AST.PrimLit "0")))
671 let block = AST.BlockSm block_label [] (AST.PMapAspect []) [tmp_dec] [AST.CSGSm gen_sm, out_assign]
672 return ([AST.CSBSm block], concat useds)
674 -- An id for the counter
675 n_id = mkVHDLBasicId "n"
676 n_cur = idToVHDLExpr n_id
677 -- An expression for previous n
678 n_prev = if left then (n_cur AST.:-: (AST.PrimLit "1"))
679 else (n_cur AST.:+: (AST.PrimLit "1"))
680 -- An id for the tmp result vector
681 tmp_id = mkVHDLBasicId "tmp"
682 tmp_name = AST.NSimple tmp_id
683 -- Generate parts of the fold
684 genFirstCell, genOtherCell :: TranslatorSession (AST.GenerateSm, [CoreSyn.CoreBndr])
686 len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) vec
687 let cond_label = mkVHDLExtId "firstcell"
688 -- if n == 0 or n == len-1
689 let cond_scheme = AST.IfGn $ n_cur AST.:=: (if left then (AST.PrimLit "0")
690 else (AST.PrimLit $ show (len-1)))
691 -- Output to tmp[current n]
692 let resname = mkIndexedName tmp_name n_cur
694 argexpr1 <- MonadState.lift tsType $ varToVHDLExpr start
695 -- Input from vec[current n]
696 let argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName vec) n_cur
697 (app_concsms, used) <- genApplication (Right resname) folded_f ( if left then
698 [Right argexpr1, Right argexpr2]
700 [Right argexpr2, Right argexpr1]
702 -- Return the conditional generate part
703 return (AST.GenerateSm cond_label cond_scheme [] app_concsms, used)
706 len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) vec
707 let cond_label = mkVHDLExtId "othercell"
708 -- if n > 0 or n < len-1
709 let cond_scheme = AST.IfGn $ n_cur AST.:/=: (if left then (AST.PrimLit "0")
710 else (AST.PrimLit $ show (len-1)))
711 -- Output to tmp[current n]
712 let resname = mkIndexedName tmp_name n_cur
713 -- Input from tmp[previous n]
714 let argexpr1 = vhdlNameToVHDLExpr $ mkIndexedName tmp_name n_prev
715 -- Input from vec[current n]
716 let argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName vec) n_cur
717 (app_concsms, used) <- genApplication (Right resname) folded_f ( if left then
718 [Right argexpr1, Right argexpr2]
720 [Right argexpr2, Right argexpr1]
722 -- Return the conditional generate part
723 return (AST.GenerateSm cond_label cond_scheme [] app_concsms, used)
725 -- | Generate a generate statement for the builtin function "zip"
726 genZip :: BuiltinBuilder
727 genZip = genNoInsts $ genVarArgs genZip'
728 genZip' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession [AST.ConcSm]
729 genZip' (Left res) f args@[arg1, arg2] = do {
730 -- Setup the generate scheme
731 ; len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) res
732 -- TODO: Use something better than varToString
733 ; let { label = mkVHDLExtId ("zipVector" ++ (varToString res))
734 ; n_id = mkVHDLBasicId "n"
735 ; n_expr = idToVHDLExpr n_id
736 ; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
737 ; genScheme = AST.ForGn n_id range
738 ; resname' = mkIndexedName (varToVHDLName res) n_expr
739 ; argexpr1 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg1) n_expr
740 ; argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg2) n_expr
742 ; labels <- MonadState.lift tsType $ getFieldLabels (tfvec_elem (Var.varType res))
743 ; let { resnameA = mkSelectedName resname' (labels!!0)
744 ; resnameB = mkSelectedName resname' (labels!!1)
745 ; resA_assign = mkUncondAssign (Right resnameA) argexpr1
746 ; resB_assign = mkUncondAssign (Right resnameB) argexpr2
748 -- Return the generate functions
749 ; return [AST.CSGSm $ AST.GenerateSm label genScheme [] [resA_assign,resB_assign]]
752 -- | Generate a generate statement for the builtin function "fst"
753 genFst :: BuiltinBuilder
754 genFst = genNoInsts $ genVarArgs genFst'
755 genFst' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession [AST.ConcSm]
756 genFst' (Left res) f args@[arg] = do {
757 ; labels <- MonadState.lift tsType $ getFieldLabels (Var.varType arg)
758 ; let { argexpr' = varToVHDLName arg
759 ; argexprA = vhdlNameToVHDLExpr $ mkSelectedName argexpr' (labels!!0)
760 ; assign = mkUncondAssign (Left res) argexprA
762 -- Return the generate functions
766 -- | Generate a generate statement for the builtin function "snd"
767 genSnd :: BuiltinBuilder
768 genSnd = genNoInsts $ genVarArgs genSnd'
769 genSnd' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession [AST.ConcSm]
770 genSnd' (Left res) f args@[arg] = do {
771 ; labels <- MonadState.lift tsType $ getFieldLabels (Var.varType arg)
772 ; let { argexpr' = varToVHDLName arg
773 ; argexprB = vhdlNameToVHDLExpr $ mkSelectedName argexpr' (labels!!1)
774 ; assign = mkUncondAssign (Left res) argexprB
776 -- Return the generate functions
780 -- | Generate a generate statement for the builtin function "unzip"
781 genUnzip :: BuiltinBuilder
782 genUnzip = genNoInsts $ genVarArgs genUnzip'
783 genUnzip' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession [AST.ConcSm]
784 genUnzip' (Left res) f args@[arg] = do
785 let error_msg = "\nGenerate.genUnzip: Cannot generate unzip call: " ++ pprString res ++ " = " ++ pprString f ++ " " ++ pprString arg
786 htype <- MonadState.lift tsType $ mkHType error_msg (Var.varType arg)
787 -- Prepare a unconditional assignment, for the case when either part
788 -- of the unzip is a state variable, which will disappear in the
789 -- resulting VHDL, making the the unzip no longer required.
791 -- A normal vector containing two-tuples
792 VecType _ (AggrType _ [_, _]) -> do {
793 -- Setup the generate scheme
794 ; len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) arg
795 -- TODO: Use something better than varToString
796 ; let { label = mkVHDLExtId ("unzipVector" ++ (varToString res))
797 ; n_id = mkVHDLBasicId "n"
798 ; n_expr = idToVHDLExpr n_id
799 ; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
800 ; genScheme = AST.ForGn n_id range
801 ; resname' = varToVHDLName res
802 ; argexpr' = mkIndexedName (varToVHDLName arg) n_expr
804 ; reslabels <- MonadState.lift tsType $ getFieldLabels (Var.varType res)
805 ; arglabels <- MonadState.lift tsType $ getFieldLabels (tfvec_elem (Var.varType arg))
806 ; let { resnameA = mkIndexedName (mkSelectedName resname' (reslabels!!0)) n_expr
807 ; resnameB = mkIndexedName (mkSelectedName resname' (reslabels!!1)) n_expr
808 ; argexprA = vhdlNameToVHDLExpr $ mkSelectedName argexpr' (arglabels!!0)
809 ; argexprB = vhdlNameToVHDLExpr $ mkSelectedName argexpr' (arglabels!!1)
810 ; resA_assign = mkUncondAssign (Right resnameA) argexprA
811 ; resB_assign = mkUncondAssign (Right resnameB) argexprB
813 -- Return the generate functions
814 ; return [AST.CSGSm $ AST.GenerateSm label genScheme [] [resA_assign,resB_assign]]
816 -- Both elements of the tuple were state, so they've disappeared. No
817 -- need to do anything
818 VecType _ (AggrType _ []) -> return []
819 -- A vector containing aggregates with more than two elements?
820 VecType _ (AggrType _ _) -> error $ "Unzipping a value that is not a vector of two-tuples? Value: " ++ pprString arg ++ "\nType: " ++ pprString (Var.varType arg)
821 -- One of the elements of the tuple was state, so there won't be a
822 -- tuple (record) in the VHDL output. We can just do a plain
825 argexpr <- MonadState.lift tsType $ varToVHDLExpr arg
826 return [mkUncondAssign (Left res) argexpr]
827 _ -> error $ "Unzipping a value that is not a vector? Value: " ++ pprString arg ++ "\nType: " ++ pprString (Var.varType arg) ++ "\nhtype: " ++ show htype
829 genCopy :: BuiltinBuilder
830 genCopy = genNoInsts genCopy'
831 genCopy' :: (Either CoreSyn.CoreBndr AST.VHDLName ) -> CoreSyn.CoreBndr -> [Either CoreSyn.CoreExpr AST.Expr] -> TranslatorSession [AST.ConcSm]
832 genCopy' (Left res) f [arg] = do {
833 ; [arg'] <- argsToVHDLExprs [arg]
834 ; let { resExpr = AST.Aggregate [AST.ElemAssoc (Just AST.Others) arg']
835 ; out_assign = mkUncondAssign (Left res) resExpr
837 ; return [out_assign]
840 genConcat :: BuiltinBuilder
841 genConcat = genNoInsts $ genVarArgs genConcat'
842 genConcat' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession [AST.ConcSm]
843 genConcat' (Left res) f args@[arg] = do {
844 -- Setup the generate scheme
845 ; len1 <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) arg
846 ; let (_, nvec) = Type.splitAppTy (Var.varType arg)
847 ; len2 <- MonadState.lift tsType $ tfp_to_int $ tfvec_len_ty nvec
848 -- TODO: Use something better than varToString
849 ; let { label = mkVHDLExtId ("concatVector" ++ (varToString res))
850 ; n_id = mkVHDLBasicId "n"
851 ; n_expr = idToVHDLExpr n_id
852 ; fromRange = n_expr AST.:*: (AST.PrimLit $ show len2)
853 ; genScheme = AST.ForGn n_id range
854 -- Create the content of the generate statement: Applying the mapped_f to
855 -- each of the elements in arg, storing to each element in res
856 ; toRange = (n_expr AST.:*: (AST.PrimLit $ show len2)) AST.:+: (AST.PrimLit $ show (len2-1))
857 ; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len1-1))
858 ; resname = vecSlice fromRange toRange
859 ; argexpr = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg) n_expr
860 ; out_assign = mkUncondAssign (Right resname) argexpr
862 -- Return the generate statement
863 ; return [AST.CSGSm $ AST.GenerateSm label genScheme [] [out_assign]]
866 vecSlice init last = AST.NSlice (AST.SliceName (varToVHDLName res)
867 (AST.ToRange init last))
869 genIteraten :: BuiltinBuilder
870 genIteraten dst f args = genIterate dst f (tail args)
872 genIterate :: BuiltinBuilder
873 genIterate = genIterateOrGenerate True
875 genGeneraten :: BuiltinBuilder
876 genGeneraten dst f args = genGenerate dst f (tail args)
878 genGenerate :: BuiltinBuilder
879 genGenerate = genIterateOrGenerate False
881 genIterateOrGenerate :: Bool -> BuiltinBuilder
882 genIterateOrGenerate iter = genVarArgs (genIterateOrGenerate' iter)
884 genIterateOrGenerate' :: Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
885 genIterateOrGenerate' iter (Left res) f args = do
886 len <- MonadState.lift tsType $ tfp_to_int ((tfvec_len_ty . Var.varType) res)
887 genIterateOrGenerate'' len iter (Left res) f args
889 genIterateOrGenerate'' :: Int -> Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
890 -- Special case for an empty input vector, just assign start to res
891 genIterateOrGenerate'' len iter (Left res) _ [app_f, start] | len == 0 = return ([mkUncondAssign (Left res) (AST.PrimLit "\"\"")], [])
893 genIterateOrGenerate'' len iter (Left res) f [app_f, start] = do
895 -- len <- MonadState.lift tsType $ tfp_to_int ((tfvec_len_ty . Var.varType) res)
896 -- An expression for len-1
897 let len_min_expr = (AST.PrimLit $ show (len-1))
898 -- -- evec is (TFVec n), so it still needs an element type
899 -- let (nvec, _) = splitAppTy (Var.varType vec)
900 -- -- Put the type of the start value in nvec, this will be the type of our
901 -- -- temporary vector
902 let tmp_ty = Var.varType res
903 let error_msg = "\nGenerate.genFold': Can not construct temp vector for element type: " ++ pprString tmp_ty
904 -- TODO: Handle Nothing
905 Just tmp_vhdl_ty <- MonadState.lift tsType $ vhdlTy error_msg tmp_ty
906 -- Setup the generate scheme
907 let gen_label = mkVHDLExtId ("iterateVector" ++ (varToString start))
908 let block_label = mkVHDLExtId ("iterateVector" ++ (varToString res))
909 let gen_range = AST.ToRange (AST.PrimLit "0") len_min_expr
910 let gen_scheme = AST.ForGn n_id gen_range
911 -- Make the intermediate vector
912 let tmp_dec = AST.BDISD $ AST.SigDec tmp_id tmp_vhdl_ty Nothing
913 -- Create the generate statement
914 cells' <- sequence [genFirstCell, genOtherCell]
915 let (cells, useds) = unzip cells'
916 let gen_sm = AST.GenerateSm gen_label gen_scheme [] (map AST.CSGSm cells)
917 -- Assign tmp[len-1] or tmp[0] to res
918 let out_assign = mkUncondAssign (Left res) $ vhdlNameToVHDLExpr tmp_name
919 let block = AST.BlockSm block_label [] (AST.PMapAspect []) [tmp_dec] [AST.CSGSm gen_sm, out_assign]
920 return ([AST.CSBSm block], concat useds)
922 -- An id for the counter
923 n_id = mkVHDLBasicId "n"
924 n_cur = idToVHDLExpr n_id
925 -- An expression for previous n
926 n_prev = n_cur AST.:-: (AST.PrimLit "1")
927 -- An id for the tmp result vector
928 tmp_id = mkVHDLBasicId "tmp"
929 tmp_name = AST.NSimple tmp_id
930 -- Generate parts of the fold
931 genFirstCell, genOtherCell :: TranslatorSession (AST.GenerateSm, [CoreSyn.CoreBndr])
933 let cond_label = mkVHDLExtId "firstcell"
934 -- if n == 0 or n == len-1
935 let cond_scheme = AST.IfGn $ n_cur AST.:=: (AST.PrimLit "0")
936 -- Output to tmp[current n]
937 let resname = mkIndexedName tmp_name n_cur
939 argexpr <- MonadState.lift tsType $ varToVHDLExpr start
940 let startassign = mkUncondAssign (Right resname) argexpr
941 (app_concsms, used) <- genApplication (Right resname) app_f [Right argexpr]
942 -- Return the conditional generate part
943 let gensm = AST.GenerateSm cond_label cond_scheme [] (if iter then
951 let cond_label = mkVHDLExtId "othercell"
952 -- if n > 0 or n < len-1
953 let cond_scheme = AST.IfGn $ n_cur AST.:/=: (AST.PrimLit "0")
954 -- Output to tmp[current n]
955 let resname = mkIndexedName tmp_name n_cur
956 -- Input from tmp[previous n]
957 let argexpr = vhdlNameToVHDLExpr $ mkIndexedName tmp_name n_prev
958 (app_concsms, used) <- genApplication (Right resname) app_f [Right argexpr]
959 -- Return the conditional generate part
960 return (AST.GenerateSm cond_label cond_scheme [] app_concsms, used)
962 genBlockRAM :: BuiltinBuilder
963 genBlockRAM = genNoInsts $ genExprArgs genBlockRAM'
965 genBlockRAM' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession [AST.ConcSm]
966 genBlockRAM' (Left res) f args@[data_in,rdaddr,wraddr,wrenable] = do
968 let (tup,data_out) = Type.splitAppTy (Var.varType res)
969 let (tup',ramvec) = Type.splitAppTy tup
970 let Just realram = Type.coreView ramvec
971 let Just (tycon, types) = Type.splitTyConApp_maybe realram
972 Just ram_vhdl_ty <- MonadState.lift tsType $ vhdlTy "wtf" (head types)
973 -- Make the intermediate vector
974 let ram_dec = AST.BDISD $ AST.SigDec ram_id ram_vhdl_ty Nothing
975 -- Get the data_out name
976 -- reslabels <- MonadState.lift tsType $ getFieldLabels (Var.varType res)
977 let resname = varToVHDLName res
978 -- let resname = mkSelectedName resname' (reslabels!!0)
979 let rdaddr_int = genExprFCall (mkVHDLBasicId toIntegerId) rdaddr
980 let argexpr = vhdlNameToVHDLExpr $ mkIndexedName (AST.NSimple ram_id) rdaddr_int
981 let assign = mkUncondAssign (Right resname) argexpr
982 let block_label = mkVHDLExtId ("blockRAM" ++ (varToString res))
983 let block = AST.BlockSm block_label [] (AST.PMapAspect []) [ram_dec] [assign, mkUpdateProcSm]
984 return [AST.CSBSm block]
986 ram_id = mkVHDLBasicId "ram"
987 mkUpdateProcSm :: AST.ConcSm
988 mkUpdateProcSm = AST.CSPSm $ AST.ProcSm proclabel [clockId] [statement]
990 proclabel = mkVHDLBasicId "updateRAM"
991 rising_edge = mkVHDLBasicId "rising_edge"
992 wraddr_int = genExprFCall (mkVHDLBasicId toIntegerId) wraddr
993 ramloc = mkIndexedName (AST.NSimple ram_id) wraddr_int
994 wform = AST.Wform [AST.WformElem data_in Nothing]
995 ramassign = AST.SigAssign ramloc wform
996 rising_edge_clk = genExprFCall rising_edge (AST.PrimName $ AST.NSimple clockId)
997 statement = AST.IfSm (AST.And rising_edge_clk wrenable) [ramassign] [] Nothing
999 genSplit :: BuiltinBuilder
1000 genSplit = genNoInsts $ genVarArgs genSplit'
1002 genSplit' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession [AST.ConcSm]
1003 genSplit' (Left res) f args@[vecIn] = do {
1004 ; labels <- MonadState.lift tsType $ getFieldLabels (Var.varType res)
1005 ; len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) vecIn
1006 ; let { block_label = mkVHDLExtId ("split" ++ (varToString vecIn))
1007 ; halflen = round ((fromIntegral len) / 2)
1008 ; rangeL = vecSlice (AST.PrimLit "0") (AST.PrimLit $ show (halflen - 1))
1009 ; rangeR = vecSlice (AST.PrimLit $ show halflen) (AST.PrimLit $ show (len - 1))
1010 ; resname = varToVHDLName res
1011 ; resnameL = mkSelectedName resname (labels!!0)
1012 ; resnameR = mkSelectedName resname (labels!!1)
1013 ; argexprL = vhdlNameToVHDLExpr rangeL
1014 ; argexprR = vhdlNameToVHDLExpr rangeR
1015 ; out_assignL = mkUncondAssign (Right resnameL) argexprL
1016 ; out_assignR = mkUncondAssign (Right resnameR) argexprR
1017 ; block = AST.BlockSm block_label [] (AST.PMapAspect []) [] [out_assignL, out_assignR]
1019 ; return [AST.CSBSm block]
1022 vecSlice init last = AST.NSlice (AST.SliceName (varToVHDLName res)
1023 (AST.ToRange init last))
1024 -----------------------------------------------------------------------------
1025 -- Function to generate VHDL for applications
1026 -----------------------------------------------------------------------------
1028 (Either CoreSyn.CoreBndr AST.VHDLName) -- ^ Where to store the result?
1029 -> CoreSyn.CoreBndr -- ^ The function to apply
1030 -> [Either CoreSyn.CoreExpr AST.Expr] -- ^ The arguments to apply
1031 -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
1032 -- ^ The corresponding VHDL concurrent statements and entities
1034 genApplication dst f args = do
1035 nonemptydst <- case dst of
1036 Left bndr -> hasNonEmptyType bndr
1037 Right _ -> return True
1040 if Var.isGlobalId f then
1041 case Var.idDetails f of
1042 IdInfo.DataConWorkId dc -> case dst of
1043 -- It's a datacon. Create a record from its arguments.
1045 -- We have the bndr, so we can get at the type
1046 htype <- MonadState.lift tsType $ mkHTypeEither (Var.varType bndr)
1047 let argsNostate = filter (\x -> not (either hasStateType (\x -> False) x)) args
1050 [arg'] <- argsToVHDLExprs [arg]
1051 return ([mkUncondAssign dst arg'], [])
1054 Right (AggrType _ _) -> do
1055 labels <- MonadState.lift tsType $ getFieldLabels (Var.varType bndr)
1056 args' <- argsToVHDLExprs argsNostate
1057 return (zipWith mkassign labels args', [])
1059 mkassign :: AST.VHDLId -> AST.Expr -> AST.ConcSm
1060 mkassign label arg =
1061 let sel_name = mkSelectedName ((either varToVHDLName id) dst) label in
1062 mkUncondAssign (Right sel_name) arg
1063 _ -> do -- error $ "DIE!"
1064 args' <- argsToVHDLExprs argsNostate
1065 return ([mkUncondAssign dst (head args')], [])
1066 Right _ -> error "\nGenerate.genApplication(DataConWorkId): Can't generate dataconstructor application without an original binder"
1067 IdInfo.DataConWrapId dc -> case dst of
1068 -- It's a datacon. Create a record from its arguments.
1070 case (Map.lookup (varToString f) globalNameTable) of
1071 Just (arg_count, builder) ->
1072 if length args == arg_count then
1075 error $ "\nGenerate.genApplication(DataConWrapId): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args
1076 Nothing -> error $ "\nGenerate.genApplication(DataConWrapId): Can't generate dataconwrapper: " ++ (show dc)
1077 Right _ -> error "\nGenerate.genApplication(DataConWrapId): Can't generate dataconwrapper application without an original binder"
1079 -- It's a global value imported from elsewhere. These can be builtin
1080 -- functions. Look up the function name in the name table and execute
1081 -- the associated builder if there is any and the argument count matches
1082 -- (this should always be the case if it typechecks, but just to be
1084 case (Map.lookup (varToString f) globalNameTable) of
1085 Just (arg_count, builder) ->
1086 if length args == arg_count then
1089 error $ "\nGenerate.genApplication(VanillaId): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args
1091 top <- isTopLevelBinder f
1094 -- Local binder that references a top level binding. Generate a
1095 -- component instantiation.
1096 signature <- getEntity f
1097 args' <- argsToVHDLExprs args
1098 let entity_id = ent_id signature
1099 -- TODO: Using show here isn't really pretty, but we'll need some
1100 -- unique-ish value...
1101 let label = "comp_ins_" ++ (either show prettyShow) dst
1102 let portmaps = mkAssocElems args' ((either varToVHDLName id) dst) signature
1103 return ([mkComponentInst label entity_id portmaps], [f])
1105 -- Not a top level binder, so this must be a local variable reference.
1106 -- It should have a representable type (and thus, no arguments) and a
1107 -- signal should be generated for it. Just generate an unconditional
1109 -- FIXME : I DONT KNOW IF THE ABOVE COMMENT HOLDS HERE, SO FOR NOW JUST ERROR!
1110 -- f' <- MonadState.lift tsType $ varToVHDLExpr f
1111 -- return $ ([mkUncondAssign dst f'], [])
1112 do errtype <- case dst of
1114 htype <- MonadState.lift tsType $ mkHTypeEither (Var.varType bndr)
1116 Right vhd -> return $ show vhd
1117 error ("\nGenerate.genApplication(VanillaId): Using function from another module that is not a known builtin: " ++ (pprString f) ++ "::" ++ errtype)
1118 IdInfo.ClassOpId cls ->
1119 -- FIXME: Not looking for what instance this class op is called for
1120 -- Is quite stupid of course.
1121 case (Map.lookup (varToString f) globalNameTable) of
1122 Just (arg_count, builder) ->
1123 if length args == arg_count then
1126 error $ "\nGenerate.genApplication(ClassOpId): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args
1127 Nothing -> error $ "\nGenerate.genApplication(ClassOpId): Using function from another module that is not a known builtin: " ++ pprString f
1128 details -> error $ "\nGenerate.genApplication: Calling unsupported function " ++ pprString f ++ " with GlobalIdDetails " ++ pprString details
1130 top <- isTopLevelBinder f
1133 -- Local binder that references a top level binding. Generate a
1134 -- component instantiation.
1135 signature <- getEntity f
1136 args' <- argsToVHDLExprs args
1137 let entity_id = ent_id signature
1138 -- TODO: Using show here isn't really pretty, but we'll need some
1139 -- unique-ish value...
1140 let label = "comp_ins_" ++ (either (prettyShow . varToVHDLName) prettyShow) dst
1141 let portmaps = mkAssocElems args' ((either varToVHDLName id) dst) signature
1142 return ([mkComponentInst label entity_id portmaps], [f])
1144 -- Not a top level binder, so this must be a local variable reference.
1145 -- It should have a representable type (and thus, no arguments) and a
1146 -- signal should be generated for it. Just generate an unconditional
1148 do f' <- MonadState.lift tsType $ varToVHDLExpr f
1149 return ([mkUncondAssign dst f'], [])
1150 else -- Destination has empty type, don't generate anything
1152 -----------------------------------------------------------------------------
1153 -- Functions to generate functions dealing with vectors.
1154 -----------------------------------------------------------------------------
1156 -- Returns the VHDLId of the vector function with the given name for the given
1157 -- element type. Generates -- this function if needed.
1158 vectorFunId :: Type.Type -> String -> TypeSession AST.VHDLId
1159 vectorFunId el_ty fname = do
1160 let error_msg = "\nGenerate.vectorFunId: Can not construct vector function for element: " ++ pprString el_ty
1161 -- TODO: Handle the Nothing case?
1162 elemTM_maybe <- vhdlTy error_msg el_ty
1163 let elemTM = Maybe.fromMaybe
1164 (error $ "\nGenerate.vectorFunId: Cannot generate vector function \"" ++ fname ++ "\" for the empty type \"" ++ (pprString el_ty) ++ "\"")
1166 -- TODO: This should not be duplicated from mk_vector_ty. Probably but it in
1167 -- the VHDLState or something.
1168 let vectorTM = mkVHDLExtId $ "vector_" ++ (AST.fromVHDLId elemTM)
1169 typefuns <- MonadState.get tsTypeFuns
1170 el_htype <- mkHType error_msg el_ty
1171 case Map.lookup (UVecType el_htype, fname) typefuns of
1172 -- Function already generated, just return it
1173 Just (id, _) -> return id
1174 -- Function not generated yet, generate it
1176 let functions = genUnconsVectorFuns elemTM vectorTM
1177 case lookup fname functions of
1179 MonadState.modify tsTypeFuns $ Map.insert (UVecType el_htype, fname) (function_id, (fst body))
1180 mapM_ (vectorFunId el_ty) (snd body)
1182 Nothing -> error $ "\nGenerate.vectorFunId: I don't know how to generate vector function " ++ fname
1184 function_id = mkVHDLExtId fname
1186 genUnconsVectorFuns :: AST.TypeMark -- ^ type of the vector elements
1187 -> AST.TypeMark -- ^ type of the vector
1188 -> [(String, (AST.SubProgBody, [String]))]
1189 genUnconsVectorFuns elemTM vectorTM =
1190 [ (exId, (AST.SubProgBody exSpec [] [exExpr],[]))
1191 , (replaceId, (AST.SubProgBody replaceSpec [AST.SPVD replaceVar] [replaceExpr1,replaceExpr2,replaceRet],[]))
1192 , (lastId, (AST.SubProgBody lastSpec [] [lastExpr],[]))
1193 , (initId, (AST.SubProgBody initSpec [AST.SPVD initVar] [initExpr, initRet],[]))
1194 , (minimumId, (AST.SubProgBody minimumSpec [] [minimumExpr],[]))
1195 , (takeId, (AST.SubProgBody takeSpec [AST.SPVD takeVar] [takeExpr, takeRet],[minimumId]))
1196 , (dropId, (AST.SubProgBody dropSpec [AST.SPVD dropVar] [dropExpr, dropRet],[]))
1197 , (plusgtId, (AST.SubProgBody plusgtSpec [AST.SPVD plusgtVar] [plusgtExpr, plusgtRet],[]))
1198 , (emptyId, (AST.SubProgBody emptySpec [AST.SPVD emptyVar] [emptyExpr],[]))
1199 , (singletonId, (AST.SubProgBody singletonSpec [AST.SPVD singletonVar] [singletonRet],[]))
1200 , (copynId, (AST.SubProgBody copynSpec [AST.SPVD copynVar] [copynExpr],[]))
1201 , (selId, (AST.SubProgBody selSpec [AST.SPVD selVar] [selFor, selRet],[]))
1202 , (ltplusId, (AST.SubProgBody ltplusSpec [AST.SPVD ltplusVar] [ltplusExpr, ltplusRet],[]))
1203 , (plusplusId, (AST.SubProgBody plusplusSpec [AST.SPVD plusplusVar] [plusplusExpr, plusplusRet],[]))
1204 , (lengthTId, (AST.SubProgBody lengthTSpec [] [lengthTExpr],[]))
1205 , (shiftlId, (AST.SubProgBody shiftlSpec [AST.SPVD shiftlVar] [shiftlExpr, shiftlRet], [initId]))
1206 , (shiftrId, (AST.SubProgBody shiftrSpec [AST.SPVD shiftrVar] [shiftrExpr, shiftrRet], [tailId]))
1207 , (nullId, (AST.SubProgBody nullSpec [] [nullExpr], []))
1208 , (rotlId, (AST.SubProgBody rotlSpec [AST.SPVD rotlVar] [rotlExpr, rotlRet], [nullId, lastId, initId]))
1209 , (rotrId, (AST.SubProgBody rotrSpec [AST.SPVD rotrVar] [rotrExpr, rotrRet], [nullId, tailId, headId]))
1210 , (reverseId, (AST.SubProgBody reverseSpec [AST.SPVD reverseVar] [reverseFor, reverseRet], []))
1213 ixPar = AST.unsafeVHDLBasicId "ix"
1214 vecPar = AST.unsafeVHDLBasicId "vec"
1215 vec1Par = AST.unsafeVHDLBasicId "vec1"
1216 vec2Par = AST.unsafeVHDLBasicId "vec2"
1217 nPar = AST.unsafeVHDLBasicId "n"
1218 leftPar = AST.unsafeVHDLBasicId "nLeft"
1219 rightPar = AST.unsafeVHDLBasicId "nRight"
1220 iId = AST.unsafeVHDLBasicId "i"
1222 aPar = AST.unsafeVHDLBasicId "a"
1223 fPar = AST.unsafeVHDLBasicId "f"
1224 sPar = AST.unsafeVHDLBasicId "s"
1225 resId = AST.unsafeVHDLBasicId "res"
1226 exSpec = AST.Function (mkVHDLExtId exId) [AST.IfaceVarDec vecPar vectorTM,
1227 AST.IfaceVarDec ixPar unsignedTM] elemTM
1228 exExpr = AST.ReturnSm (Just $ AST.PrimName $ AST.NIndexed
1229 (AST.IndexedName (AST.NSimple vecPar) [genExprFCall (mkVHDLBasicId toIntegerId) (AST.PrimName $ AST.NSimple ixPar)]))
1230 replaceSpec = AST.Function (mkVHDLExtId replaceId) [ AST.IfaceVarDec vecPar vectorTM
1231 , AST.IfaceVarDec iPar unsignedTM
1232 , AST.IfaceVarDec aPar elemTM
1234 -- variable res : fsvec_x (0 to vec'length-1);
1237 (AST.SubtypeIn vectorTM
1238 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1239 [AST.ToRange (AST.PrimLit "0")
1240 (AST.PrimName (AST.NAttribute $
1241 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1242 (AST.PrimLit "1")) ]))
1244 -- res AST.:= vec(0 to i-1) & a & vec(i+1 to length'vec-1)
1245 replaceExpr1 = AST.NSimple resId AST.:= AST.PrimName (AST.NSimple vecPar)
1246 replaceExpr2 = AST.NIndexed (AST.IndexedName (AST.NSimple resId) [genExprFCall (mkVHDLBasicId toIntegerId) (AST.PrimName $ AST.NSimple iPar)]) AST.:= AST.PrimName (AST.NSimple aPar)
1247 replaceRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1248 vecSlice init last = AST.PrimName (AST.NSlice
1250 (AST.NSimple vecPar)
1251 (AST.ToRange init last)))
1252 lastSpec = AST.Function (mkVHDLExtId lastId) [AST.IfaceVarDec vecPar vectorTM] elemTM
1253 -- return vec(vec'length-1);
1254 lastExpr = AST.ReturnSm (Just (AST.PrimName $ AST.NIndexed (AST.IndexedName
1255 (AST.NSimple vecPar)
1256 [AST.PrimName (AST.NAttribute $
1257 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing)
1258 AST.:-: AST.PrimLit "1"])))
1259 initSpec = AST.Function (mkVHDLExtId initId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
1260 -- variable res : fsvec_x (0 to vec'length-2);
1263 (AST.SubtypeIn vectorTM
1264 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1265 [AST.ToRange (AST.PrimLit "0")
1266 (AST.PrimName (AST.NAttribute $
1267 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1268 (AST.PrimLit "2")) ]))
1270 -- resAST.:= vec(0 to vec'length-2)
1271 initExpr = AST.NSimple resId AST.:= (vecSlice
1273 (AST.PrimName (AST.NAttribute $
1274 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing)
1275 AST.:-: AST.PrimLit "2"))
1276 initRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1277 minimumSpec = AST.Function (mkVHDLExtId minimumId) [AST.IfaceVarDec leftPar naturalTM,
1278 AST.IfaceVarDec rightPar naturalTM ] naturalTM
1279 minimumExpr = AST.IfSm ((AST.PrimName $ AST.NSimple leftPar) AST.:<: (AST.PrimName $ AST.NSimple rightPar))
1280 [AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple leftPar)]
1282 (Just $ AST.Else [minimumExprRet])
1283 where minimumExprRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple rightPar)
1284 takeSpec = AST.Function (mkVHDLExtId takeId) [AST.IfaceVarDec nPar naturalTM,
1285 AST.IfaceVarDec vecPar vectorTM ] vectorTM
1286 -- variable res : fsvec_x (0 to (minimum (n,vec'length))-1);
1287 minLength = AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId minimumId))
1288 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple nPar)
1289 ,Nothing AST.:=>: AST.ADExpr (AST.PrimName (AST.NAttribute $
1290 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))]
1293 (AST.SubtypeIn vectorTM
1294 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1295 [AST.ToRange (AST.PrimLit "0")
1297 (AST.PrimLit "1")) ]))
1299 -- res AST.:= vec(0 to n-1)
1300 takeExpr = AST.NSimple resId AST.:=
1301 (vecSlice (AST.PrimLit "0")
1302 (minLength AST.:-: AST.PrimLit "1"))
1303 takeRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1304 dropSpec = AST.Function (mkVHDLExtId dropId) [AST.IfaceVarDec nPar naturalTM,
1305 AST.IfaceVarDec vecPar vectorTM ] vectorTM
1306 -- variable res : fsvec_x (0 to vec'length-n-1);
1309 (AST.SubtypeIn vectorTM
1310 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1311 [AST.ToRange (AST.PrimLit "0")
1312 (AST.PrimName (AST.NAttribute $
1313 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1314 (AST.PrimName $ AST.NSimple nPar)AST.:-: (AST.PrimLit "1")) ]))
1316 -- res AST.:= vec(n to vec'length-1)
1317 dropExpr = AST.NSimple resId AST.:= (vecSlice
1318 (AST.PrimName $ AST.NSimple nPar)
1319 (AST.PrimName (AST.NAttribute $
1320 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing)
1321 AST.:-: AST.PrimLit "1"))
1322 dropRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1323 plusgtSpec = AST.Function (mkVHDLExtId plusgtId) [AST.IfaceVarDec aPar elemTM,
1324 AST.IfaceVarDec vecPar vectorTM] vectorTM
1325 -- variable res : fsvec_x (0 to vec'length);
1328 (AST.SubtypeIn vectorTM
1329 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1330 [AST.ToRange (AST.PrimLit "0")
1331 (AST.PrimName (AST.NAttribute $
1332 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))]))
1334 plusgtExpr = AST.NSimple resId AST.:=
1335 ((AST.PrimName $ AST.NSimple aPar) AST.:&:
1336 (AST.PrimName $ AST.NSimple vecPar))
1337 plusgtRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1338 emptySpec = AST.Function (mkVHDLExtId emptyId) [] vectorTM
1341 (AST.SubtypeIn vectorTM
1342 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1343 [AST.ToRange (AST.PrimLit "0") (AST.PrimLit "-1")]))
1345 emptyExpr = AST.ReturnSm (Just $ AST.PrimName (AST.NSimple resId))
1346 singletonSpec = AST.Function (mkVHDLExtId singletonId) [AST.IfaceVarDec aPar elemTM ]
1348 -- variable res : fsvec_x (0 to 0) := (others => a);
1351 (AST.SubtypeIn vectorTM
1352 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1353 [AST.ToRange (AST.PrimLit "0") (AST.PrimLit "0")]))
1354 (Just $ AST.Aggregate [AST.ElemAssoc (Just AST.Others)
1355 (AST.PrimName $ AST.NSimple aPar)])
1356 singletonRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1357 copynSpec = AST.Function (mkVHDLExtId copynId) [AST.IfaceVarDec nPar naturalTM,
1358 AST.IfaceVarDec aPar elemTM ] vectorTM
1359 -- variable res : fsvec_x (0 to n-1) := (others => a);
1362 (AST.SubtypeIn vectorTM
1363 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1364 [AST.ToRange (AST.PrimLit "0")
1365 ((AST.PrimName (AST.NSimple nPar)) AST.:-:
1366 (AST.PrimLit "1")) ]))
1367 (Just $ AST.Aggregate [AST.ElemAssoc (Just AST.Others)
1368 (AST.PrimName $ AST.NSimple aPar)])
1370 copynExpr = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1371 selSpec = AST.Function (mkVHDLExtId selId) [AST.IfaceVarDec fPar naturalTM,
1372 AST.IfaceVarDec sPar naturalTM,
1373 AST.IfaceVarDec nPar naturalTM,
1374 AST.IfaceVarDec vecPar vectorTM ] vectorTM
1375 -- variable res : fsvec_x (0 to n-1);
1378 (AST.SubtypeIn vectorTM
1379 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1380 [AST.ToRange (AST.PrimLit "0")
1381 ((AST.PrimName (AST.NSimple nPar)) AST.:-:
1382 (AST.PrimLit "1")) ])
1385 -- for i res'range loop
1386 -- res(i) := vec(f+i*s);
1388 selFor = AST.ForSM iId (AST.AttribRange $ AST.AttribName (AST.NSimple resId) (AST.NSimple rangeId) Nothing) [selAssign]
1389 -- res(i) := vec(f+i*s);
1390 selAssign = let origExp = AST.PrimName (AST.NSimple fPar) AST.:+:
1391 (AST.PrimName (AST.NSimple iId) AST.:*:
1392 AST.PrimName (AST.NSimple sPar)) in
1393 AST.NIndexed (AST.IndexedName (AST.NSimple resId) [AST.PrimName (AST.NSimple iId)]) AST.:=
1394 (AST.PrimName $ AST.NIndexed (AST.IndexedName (AST.NSimple vecPar) [origExp]))
1396 selRet = AST.ReturnSm (Just $ AST.PrimName (AST.NSimple resId))
1397 ltplusSpec = AST.Function (mkVHDLExtId ltplusId) [AST.IfaceVarDec vecPar vectorTM,
1398 AST.IfaceVarDec aPar elemTM] vectorTM
1399 -- variable res : fsvec_x (0 to vec'length);
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))]))
1408 ltplusExpr = AST.NSimple resId AST.:=
1409 ((AST.PrimName $ AST.NSimple vecPar) AST.:&:
1410 (AST.PrimName $ AST.NSimple aPar))
1411 ltplusRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1412 plusplusSpec = AST.Function (mkVHDLExtId plusplusId) [AST.IfaceVarDec vec1Par vectorTM,
1413 AST.IfaceVarDec vec2Par vectorTM]
1415 -- variable res : fsvec_x (0 to vec1'length + vec2'length -1);
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 vec1Par) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:+:
1423 AST.PrimName (AST.NAttribute $
1424 AST.AttribName (AST.NSimple vec2Par) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1427 plusplusExpr = AST.NSimple resId AST.:=
1428 ((AST.PrimName $ AST.NSimple vec1Par) AST.:&:
1429 (AST.PrimName $ AST.NSimple vec2Par))
1430 plusplusRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1431 lengthTSpec = AST.Function (mkVHDLExtId lengthTId) [AST.IfaceVarDec vecPar vectorTM] naturalTM
1432 lengthTExpr = AST.ReturnSm (Just $ AST.PrimName (AST.NAttribute $
1433 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))
1434 shiftlSpec = AST.Function (mkVHDLExtId shiftlId) [AST.IfaceVarDec vecPar vectorTM,
1435 AST.IfaceVarDec aPar elemTM ] vectorTM
1436 -- variable res : fsvec_x (0 to vec'length-1);
1439 (AST.SubtypeIn vectorTM
1440 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1441 [AST.ToRange (AST.PrimLit "0")
1442 (AST.PrimName (AST.NAttribute $
1443 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1444 (AST.PrimLit "1")) ]))
1446 -- res := a & init(vec)
1447 shiftlExpr = AST.NSimple resId AST.:=
1448 (AST.PrimName (AST.NSimple aPar) AST.:&:
1449 (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId initId))
1450 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]))
1451 shiftlRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1452 shiftrSpec = AST.Function (mkVHDLExtId shiftrId) [AST.IfaceVarDec vecPar vectorTM,
1453 AST.IfaceVarDec aPar elemTM ] vectorTM
1454 -- variable res : fsvec_x (0 to vec'length-1);
1457 (AST.SubtypeIn vectorTM
1458 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1459 [AST.ToRange (AST.PrimLit "0")
1460 (AST.PrimName (AST.NAttribute $
1461 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1462 (AST.PrimLit "1")) ]))
1464 -- res := tail(vec) & a
1465 shiftrExpr = AST.NSimple resId AST.:=
1466 ((AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId tailId))
1467 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]) AST.:&:
1468 (AST.PrimName (AST.NSimple aPar)))
1470 shiftrRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1471 nullSpec = AST.Function (mkVHDLExtId nullId) [AST.IfaceVarDec vecPar vectorTM] booleanTM
1472 -- return vec'length = 0
1473 nullExpr = AST.ReturnSm (Just $
1474 AST.PrimName (AST.NAttribute $
1475 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:=:
1477 rotlSpec = AST.Function (mkVHDLExtId rotlId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
1478 -- variable res : fsvec_x (0 to vec'length-1);
1481 (AST.SubtypeIn vectorTM
1482 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1483 [AST.ToRange (AST.PrimLit "0")
1484 (AST.PrimName (AST.NAttribute $
1485 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1486 (AST.PrimLit "1")) ]))
1488 -- if null(vec) then res := vec else res := last(vec) & init(vec)
1489 rotlExpr = AST.IfSm (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId nullId))
1490 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)])
1491 [AST.NSimple resId AST.:= (AST.PrimName $ AST.NSimple vecPar)]
1493 (Just $ AST.Else [rotlExprRet])
1495 AST.NSimple resId AST.:=
1496 ((AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId lastId))
1497 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]) AST.:&:
1498 (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId initId))
1499 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]))
1500 rotlRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1501 rotrSpec = AST.Function (mkVHDLExtId rotrId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
1502 -- variable res : fsvec_x (0 to vec'length-1);
1505 (AST.SubtypeIn vectorTM
1506 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1507 [AST.ToRange (AST.PrimLit "0")
1508 (AST.PrimName (AST.NAttribute $
1509 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1510 (AST.PrimLit "1")) ]))
1512 -- if null(vec) then res := vec else res := tail(vec) & head(vec)
1513 rotrExpr = AST.IfSm (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId nullId))
1514 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)])
1515 [AST.NSimple resId AST.:= (AST.PrimName $ AST.NSimple vecPar)]
1517 (Just $ AST.Else [rotrExprRet])
1519 AST.NSimple resId AST.:=
1520 ((AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId tailId))
1521 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]) AST.:&:
1522 (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId headId))
1523 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]))
1524 rotrRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1525 reverseSpec = AST.Function (mkVHDLExtId reverseId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
1528 (AST.SubtypeIn vectorTM
1529 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1530 [AST.ToRange (AST.PrimLit "0")
1531 (AST.PrimName (AST.NAttribute $
1532 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1533 (AST.PrimLit "1")) ]))
1535 -- for i in 0 to res'range loop
1536 -- res(vec'length-i-1) := vec(i);
1539 AST.ForSM iId (AST.AttribRange $ AST.AttribName (AST.NSimple resId) (AST.NSimple rangeId) Nothing) [reverseAssign]
1540 -- res(vec'length-i-1) := vec(i);
1541 reverseAssign = AST.NIndexed (AST.IndexedName (AST.NSimple resId) [destExp]) AST.:=
1542 (AST.PrimName $ AST.NIndexed (AST.IndexedName (AST.NSimple vecPar)
1543 [AST.PrimName $ AST.NSimple iId]))
1544 where destExp = AST.PrimName (AST.NAttribute $ AST.AttribName (AST.NSimple vecPar)
1545 (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1546 AST.PrimName (AST.NSimple iId) AST.:-:
1549 reverseRet = AST.ReturnSm (Just $ AST.PrimName (AST.NSimple resId))
1552 -----------------------------------------------------------------------------
1553 -- A table of builtin functions
1554 -----------------------------------------------------------------------------
1556 -- A function that generates VHDL for a builtin function
1557 type BuiltinBuilder =
1558 (Either CoreSyn.CoreBndr AST.VHDLName) -- ^ The destination signal and it's original type
1559 -> CoreSyn.CoreBndr -- ^ The function called
1560 -> [Either CoreSyn.CoreExpr AST.Expr] -- ^ The value arguments passed (excluding type and
1561 -- dictionary arguments).
1562 -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
1563 -- ^ The corresponding VHDL concurrent statements and entities
1566 -- A map of a builtin function to VHDL function builder
1567 type NameTable = Map.Map String (Int, BuiltinBuilder )
1569 -- | The builtin functions we support. Maps a name to an argument count and a
1570 -- builder function. If you add a name to this map, don't forget to add
1571 -- it to VHDL.Constants/builtinIds as well.
1572 globalNameTable :: NameTable
1573 globalNameTable = Map.fromList
1574 [ (exId , (2, genFCall True ) )
1575 , (replaceId , (3, genFCall False ) )
1576 , (headId , (1, genFCall True ) )
1577 , (lastId , (1, genFCall True ) )
1578 , (tailId , (1, genFCall False ) )
1579 , (initId , (1, genFCall False ) )
1580 , (takeId , (2, genFCall False ) )
1581 , (dropId , (2, genFCall False ) )
1582 , (selId , (4, genFCall False ) )
1583 , (plusgtId , (2, genFCall False ) )
1584 , (ltplusId , (2, genFCall False ) )
1585 , (plusplusId , (2, genFCall False ) )
1586 , (mapId , (2, genMap ) )
1587 , (zipWithId , (3, genZipWith ) )
1588 , (foldlId , (3, genFoldl ) )
1589 , (foldrId , (3, genFoldr ) )
1590 , (zipId , (2, genZip ) )
1591 , (unzipId , (1, genUnzip ) )
1592 , (shiftlId , (2, genFCall False ) )
1593 , (shiftrId , (2, genFCall False ) )
1594 , (rotlId , (1, genFCall False ) )
1595 , (rotrId , (1, genFCall False ) )
1596 , (concatId , (1, genConcat ) )
1597 , (reverseId , (1, genFCall False ) )
1598 , (iteratenId , (3, genIteraten ) )
1599 , (iterateId , (2, genIterate ) )
1600 , (generatenId , (3, genGeneraten ) )
1601 , (generateId , (2, genGenerate ) )
1602 , (emptyId , (0, genFCall False ) )
1603 , (singletonId , (1, genFCall False ) )
1604 , (copynId , (2, genFCall False ) )
1605 , (copyId , (1, genCopy ) )
1606 , (lengthTId , (1, genFCall False ) )
1607 , (nullId , (1, genFCall False ) )
1608 , (hwxorId , (2, genOperator2 AST.Xor ) )
1609 , (hwandId , (2, genOperator2 AST.And ) )
1610 , (hworId , (2, genOperator2 AST.Or ) )
1611 , (hwnotId , (1, genOperator1 AST.Not ) )
1612 , (equalityId , (2, genOperator2 (AST.:=:) ) )
1613 , (inEqualityId , (2, genOperator2 (AST.:/=:) ) )
1614 , (ltId , (2, genOperator2 (AST.:<:) ) )
1615 , (lteqId , (2, genOperator2 (AST.:<=:) ) )
1616 , (gtId , (2, genOperator2 (AST.:>:) ) )
1617 , (gteqId , (2, genOperator2 (AST.:>=:) ) )
1618 , (boolOrId , (2, genOperator2 AST.Or ) )
1619 , (boolAndId , (2, genOperator2 AST.And ) )
1620 , (boolNot , (1, genOperator1 AST.Not ) )
1621 , (plusId , (2, genOperator2 (AST.:+:) ) )
1622 , (timesId , (2, genTimes ) )
1623 , (negateId , (1, genNegation ) )
1624 , (minusId , (2, genOperator2 (AST.:-:) ) )
1625 , (fromSizedWordId , (1, genFromSizedWord ) )
1626 , (fromRangedWordId , (1, genFromRangedWord ) )
1627 , (fromIntegerId , (1, genFromInteger ) )
1628 , (resizeWordId , (1, genResize ) )
1629 , (resizeIntId , (1, genResize ) )
1630 , (sizedIntId , (1, genSizedInt ) )
1631 , (smallIntegerId , (1, genFromInteger ) )
1632 , (fstId , (1, genFst ) )
1633 , (sndId , (1, genSnd ) )
1634 , (blockRAMId , (5, genBlockRAM ) )
1635 , (splitId , (1, genSplit ) )
1636 --, (tfvecId , (1, genTFVec ) )
1637 , (minimumId , (2, error "\nFunction name: \"minimum\" is used internally, use another name"))