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
10 import Data.Accessor.MonadState as MonadState
14 import qualified Language.VHDL.AST as AST
17 import qualified CoreSyn
21 import qualified IdInfo
22 import qualified Literal
24 import qualified TyCon
27 import CLasH.Translator.TranslatorTypes
28 import CLasH.VHDL.Constants
29 import CLasH.VHDL.VHDLTypes
30 import CLasH.VHDL.VHDLTools
31 import CLasH.Utils as Utils
32 import CLasH.Utils.Core.CoreTools
33 import CLasH.Utils.Pretty
34 import qualified CLasH.Normalize as Normalize
36 -----------------------------------------------------------------------------
37 -- Functions to generate VHDL for user-defined functions.
38 -----------------------------------------------------------------------------
40 -- | Create an entity for a given function
43 -> TranslatorSession Entity -- ^ The resulting entity
45 getEntity fname = Utils.makeCached fname tsEntities $ do
46 expr <- Normalize.getNormalized fname
47 -- Split the normalized expression
48 let (args, binds, res) = Normalize.splitNormalized expr
49 -- Generate ports for all non-empty types
50 args' <- catMaybesM $ mapM mkMap args
51 -- TODO: Handle Nothing
53 count <- getA tsEntityCounter
54 let vhdl_id = mkVHDLBasicId $ varToString fname ++ "Component_" ++ show count
55 putA tsEntityCounter (count + 1)
56 let ent_decl = createEntityAST vhdl_id args' res'
57 let signature = Entity vhdl_id args' res' ent_decl
61 --[(SignalId, SignalInfo)]
63 -> TranslatorSession (Maybe Port)
66 --info = Maybe.fromMaybe
67 -- (error $ "Signal not found in the name map? This should not happen!")
69 -- Assume the bndr has a valid VHDL id already
72 error_msg = "\nVHDL.createEntity.mkMap: Can not create entity: " ++ pprString fname ++ "\nbecause no type can be created for port: " ++ pprString bndr
74 type_mark_maybe <- MonadState.lift tsType $ vhdl_ty error_msg ty
75 case type_mark_maybe of
76 Just type_mark -> return $ Just (id, type_mark)
77 Nothing -> return Nothing
80 -- | Create the VHDL AST for an entity
82 AST.VHDLId -- ^ The name of the function
83 -> [Port] -- ^ The entity's arguments
84 -> Maybe Port -- ^ The entity's result
85 -> AST.EntityDec -- ^ The entity with the ent_decl filled in as well
87 createEntityAST vhdl_id args res =
88 AST.EntityDec vhdl_id ports
90 -- Create a basic Id, since VHDL doesn't grok filenames with extended Ids.
91 ports = map (mkIfaceSigDec AST.In) args
92 ++ (Maybe.maybeToList res_port)
93 ++ [clk_port,resetn_port]
94 -- Add a clk port if we have state
95 clk_port = AST.IfaceSigDec clockId AST.In std_logicTM
96 resetn_port = AST.IfaceSigDec resetId AST.In std_logicTM
97 res_port = fmap (mkIfaceSigDec AST.Out) res
99 -- | Create a port declaration
101 AST.Mode -- ^ The mode for the port (In / Out)
102 -> Port -- ^ The id and type for the port
103 -> AST.IfaceSigDec -- ^ The resulting port declaration
105 mkIfaceSigDec mode (id, ty) = AST.IfaceSigDec id mode ty
107 -- | Create an architecture for a given function
109 CoreSyn.CoreBndr -- ^ The function to get an architecture for
110 -> TranslatorSession (Architecture, [CoreSyn.CoreBndr])
111 -- ^ The architecture for this function
113 getArchitecture fname = Utils.makeCached fname tsArchitectures $ do
114 expr <- Normalize.getNormalized fname
115 -- Split the normalized expression
116 let (args, binds, res) = Normalize.splitNormalized expr
118 -- Get the entity for this function
119 signature <- getEntity fname
120 let entity_id = ent_id signature
122 -- Create signal declarations for all binders in the let expression, except
123 -- for the output port (that will already have an output port declared in
125 sig_dec_maybes <- mapM (mkSigDec . fst) (filter ((/=res).fst) binds)
126 let sig_decs = Maybe.catMaybes $ sig_dec_maybes
127 -- Process each bind, resulting in info about state variables and concurrent
129 (state_vars, sms) <- Monad.mapAndUnzipM dobind binds
130 let (in_state_maybes, out_state_maybes) = unzip state_vars
131 let (statementss, used_entitiess) = unzip sms
132 -- Create a state proc, if needed
133 state_proc <- case (Maybe.catMaybes in_state_maybes, Maybe.catMaybes out_state_maybes) of
134 ([in_state], [out_state]) -> mkStateProcSm (in_state, out_state)
135 ([], []) -> return []
136 (ins, outs) -> error $ "Weird use of state in " ++ show fname ++ ". In: " ++ show ins ++ " Out: " ++ show outs
137 -- Join the create statements and the (optional) state_proc
138 let statements = concat statementss ++ state_proc
139 -- Create the architecture
140 let arch = AST.ArchBody (mkVHDLBasicId "structural") (AST.NSimple entity_id) (map AST.BDISD sig_decs) statements
141 let used_entities = concat used_entitiess
142 return (arch, used_entities)
144 dobind :: (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The bind to process
145 -> TranslatorSession ((Maybe CoreSyn.CoreBndr, Maybe CoreSyn.CoreBndr), ([AST.ConcSm], [CoreSyn.CoreBndr]))
146 -- ^ ((Input state variable, output state variable), (statements, used entities))
147 -- newtype unpacking is just a cast
148 dobind (bndr, unpacked@(CoreSyn.Cast packed coercion))
149 | hasStateType packed && not (hasStateType unpacked)
150 = return ((Just bndr, Nothing), ([], []))
151 -- With simplCore, newtype packing is just a cast
152 dobind (bndr, packed@(CoreSyn.Cast unpacked@(CoreSyn.Var state) coercion))
153 | hasStateType packed && not (hasStateType unpacked)
154 = return ((Nothing, Just state), ([], []))
155 -- Without simplCore, newtype packing uses a data constructor
156 dobind (bndr, (CoreSyn.App (CoreSyn.App (CoreSyn.Var con) (CoreSyn.Type _)) (CoreSyn.Var state)))
158 = return ((Nothing, Just state), ([], []))
159 -- Anything else is handled by mkConcSm
162 return ((Nothing, Nothing), sms)
165 (CoreSyn.CoreBndr, CoreSyn.CoreBndr) -- ^ The current and new state variables
166 -> TranslatorSession [AST.ConcSm] -- ^ The resulting statements
167 mkStateProcSm (old, new) = do
168 nonempty <- hasNonEmptyType old
170 then return [AST.CSPSm $ AST.ProcSm label [clk] [statement]]
173 label = mkVHDLBasicId $ "state"
174 clk = mkVHDLBasicId "clock"
175 rising_edge = AST.NSimple $ mkVHDLBasicId "rising_edge"
176 wform = AST.Wform [AST.WformElem (AST.PrimName $ varToVHDLName new) Nothing]
177 assign = AST.SigAssign (varToVHDLName old) wform
178 rising_edge_clk = AST.PrimFCall $ AST.FCall rising_edge [Nothing AST.:=>: (AST.ADName $ AST.NSimple clk)]
179 statement = AST.IfSm rising_edge_clk [assign] [] Nothing
182 -- | Transforms a core binding into a VHDL concurrent statement
184 (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The binding to process
185 -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
186 -- ^ The corresponding VHDL concurrent statements and entities
190 -- Ignore Cast expressions, they should not longer have any meaning as long as
191 -- the type works out. Throw away state repacking
192 mkConcSm (bndr, to@(CoreSyn.Cast from ty))
193 | hasStateType to && hasStateType from
195 mkConcSm (bndr, CoreSyn.Cast expr ty) = mkConcSm (bndr, expr)
197 -- Simple a = b assignments are just like applications, but without arguments.
198 -- We can't just generate an unconditional assignment here, since b might be a
199 -- top level binding (e.g., a function with no arguments).
200 mkConcSm (bndr, CoreSyn.Var v) = do
201 genApplication (Left bndr) v []
203 mkConcSm (bndr, app@(CoreSyn.App _ _))= do
204 let (CoreSyn.Var f, args) = CoreSyn.collectArgs app
205 let valargs = get_val_args (Var.varType f) args
206 genApplication (Left bndr) f (map Left valargs)
208 -- A single alt case must be a selector. This means thee scrutinee is a simple
209 -- variable, the alternative is a dataalt with a single non-wild binder that
211 mkConcSm (bndr, expr@(CoreSyn.Case (CoreSyn.Var scrut) b ty [alt]))
212 -- Don't generate VHDL for substate extraction
213 | hasStateType bndr = return ([], [])
216 (CoreSyn.DataAlt dc, bndrs, (CoreSyn.Var sel_bndr)) -> do
217 bndrs' <- Monad.filterM hasNonEmptyType bndrs
218 case List.elemIndex sel_bndr bndrs' of
220 labels <- MonadState.lift tsType $ getFieldLabels (Id.idType scrut)
221 let label = labels!!i
222 let sel_name = mkSelectedName (varToVHDLName scrut) label
223 let sel_expr = AST.PrimName sel_name
224 return ([mkUncondAssign (Left bndr) sel_expr], [])
225 Nothing -> error $ "\nVHDL.mkConcSM: Not in normal form: Not a selector case:\n" ++ (pprString expr)
227 _ -> error $ "\nVHDL.mkConcSM: Not in normal form: Not a selector case:\n" ++ (pprString expr)
229 -- Multiple case alt are be conditional assignments and have only wild
230 -- binders in the alts and only variables in the case values and a variable
231 -- for a scrutinee. We check the constructor of the second alt, since the
232 -- first is the default case, if there is any.
233 mkConcSm (bndr, (CoreSyn.Case (CoreSyn.Var scrut) b ty [(_, _, CoreSyn.Var false), (con, _, CoreSyn.Var true)])) = do
234 scrut' <- MonadState.lift tsType $ varToVHDLExpr scrut
235 let cond_expr = scrut' AST.:=: (altconToVHDLExpr con)
236 true_expr <- MonadState.lift tsType $ varToVHDLExpr true
237 false_expr <- MonadState.lift tsType $ varToVHDLExpr false
238 return ([mkCondAssign (Left bndr) cond_expr true_expr false_expr], [])
240 mkConcSm (_, (CoreSyn.Case (CoreSyn.Var _) _ _ alts)) = error "\nVHDL.mkConcSm: Not in normal form: Case statement with more than two alternatives"
241 mkConcSm (_, CoreSyn.Case _ _ _ _) = error "\nVHDL.mkConcSm: Not in normal form: Case statement has does not have a simple variable as scrutinee"
242 mkConcSm (bndr, expr) = error $ "\nVHDL.mkConcSM: Unsupported binding in let expression: " ++ pprString bndr ++ " = " ++ pprString expr
244 -----------------------------------------------------------------------------
245 -- Functions to generate VHDL for builtin functions
246 -----------------------------------------------------------------------------
248 -- | A function to wrap a builder-like function that expects its arguments to
250 genExprArgs wrap dst func args = do
251 args' <- argsToVHDLExprs args
254 -- | Turn the all lefts into VHDL Expressions.
255 argsToVHDLExprs :: [Either CoreSyn.CoreExpr AST.Expr] -> TranslatorSession [AST.Expr]
256 argsToVHDLExprs = catMaybesM . (mapM argToVHDLExpr)
258 argToVHDLExpr :: Either CoreSyn.CoreExpr AST.Expr -> TranslatorSession (Maybe AST.Expr)
259 argToVHDLExpr (Left expr) = MonadState.lift tsType $ do
260 let errmsg = "Generate.argToVHDLExpr: Using non-representable type? Should not happen!"
261 ty_maybe <- vhdl_ty errmsg expr
264 vhdl_expr <- varToVHDLExpr $ exprToVar expr
265 return $ Just vhdl_expr
266 Nothing -> return $ Nothing
268 argToVHDLExpr (Right expr) = return $ Just expr
270 -- A function to wrap a builder-like function that generates no component
273 (dst -> func -> args -> TranslatorSession [AST.ConcSm])
274 -> (dst -> func -> args -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr]))
275 genNoInsts wrap dst func args = do
276 concsms <- wrap dst func args
279 -- | A function to wrap a builder-like function that expects its arguments to
282 (dst -> func -> [Var.Var] -> res)
283 -> (dst -> func -> [Either CoreSyn.CoreExpr AST.Expr] -> res)
284 genVarArgs wrap dst func args = wrap dst func args'
286 args' = map exprToVar exprargs
287 -- Check (rather crudely) that all arguments are CoreExprs
288 (exprargs, []) = Either.partitionEithers args
290 -- | A function to wrap a builder-like function that expects its arguments to
293 (dst -> func -> [Literal.Literal] -> res)
294 -> (dst -> func -> [Either CoreSyn.CoreExpr AST.Expr] -> res)
295 genLitArgs wrap dst func args = wrap dst func args'
297 args' = map exprToLit litargs
298 -- FIXME: Check if we were passed an CoreSyn.App
299 litargs = concat (map getLiterals exprargs)
300 (exprargs, []) = Either.partitionEithers args
302 -- | A function to wrap a builder-like function that produces an expression
303 -- and expects it to be assigned to the destination.
305 ((Either CoreSyn.CoreBndr AST.VHDLName) -> func -> [arg] -> TranslatorSession AST.Expr)
306 -> ((Either CoreSyn.CoreBndr AST.VHDLName) -> func -> [arg] -> TranslatorSession [AST.ConcSm])
307 genExprRes wrap dst func args = do
308 expr <- wrap dst func args
309 return $ [mkUncondAssign dst expr]
311 -- | Generate a binary operator application. The first argument should be a
312 -- constructor from the AST.Expr type, e.g. AST.And.
313 genOperator2 :: (AST.Expr -> AST.Expr -> AST.Expr) -> BuiltinBuilder
314 genOperator2 op = genNoInsts $ genExprArgs $ genExprRes (genOperator2' op)
315 genOperator2' :: (AST.Expr -> AST.Expr -> AST.Expr) -> dst -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession AST.Expr
316 genOperator2' op _ f [arg1, arg2] = return $ op arg1 arg2
318 -- | Generate a unary operator application
319 genOperator1 :: (AST.Expr -> AST.Expr) -> BuiltinBuilder
320 genOperator1 op = genNoInsts $ genExprArgs $ genExprRes (genOperator1' op)
321 genOperator1' :: (AST.Expr -> AST.Expr) -> dst -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession AST.Expr
322 genOperator1' op _ f [arg] = return $ op arg
324 -- | Generate a unary operator application
325 genNegation :: BuiltinBuilder
326 genNegation = genNoInsts $ genVarArgs $ genExprRes genNegation'
327 genNegation' :: dst -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession AST.Expr
328 genNegation' _ f [arg] = do
329 arg1 <- MonadState.lift tsType $ varToVHDLExpr arg
330 let ty = Var.varType arg
331 let (tycon, args) = Type.splitTyConApp ty
332 let name = Name.getOccString (TyCon.tyConName tycon)
334 "SizedInt" -> return $ AST.Neg arg1
335 otherwise -> error $ "\nGenerate.genNegation': Negation allowed for type: " ++ show name
337 -- | Generate a function call from the destination binder, function name and a
338 -- list of expressions (its arguments)
339 genFCall :: Bool -> BuiltinBuilder
340 genFCall switch = genNoInsts $ genExprArgs $ genExprRes (genFCall' switch)
341 genFCall' :: Bool -> Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession AST.Expr
342 genFCall' switch (Left res) f args = do
343 let fname = varToString f
344 let el_ty = if switch then (Var.varType res) else ((tfvec_elem . Var.varType) res)
345 id <- MonadState.lift tsType $ vectorFunId el_ty fname
346 return $ AST.PrimFCall $ AST.FCall (AST.NSimple id) $
347 map (\exp -> Nothing AST.:=>: AST.ADExpr exp) args
348 genFCall' _ (Right name) _ _ = error $ "\nGenerate.genFCall': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
350 genFromSizedWord :: BuiltinBuilder
351 genFromSizedWord = genNoInsts $ genExprArgs genFromSizedWord'
352 genFromSizedWord' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession [AST.ConcSm]
353 genFromSizedWord' (Left res) f args@[arg] = do
354 return $ [mkUncondAssign (Left res) arg]
355 -- let fname = varToString f
356 -- return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId toIntegerId)) $
357 -- map (\exp -> Nothing AST.:=>: AST.ADExpr exp) args
358 genFromSizedWord' (Right name) _ _ = error $ "\nGenerate.genFromSizedWord': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
360 genResize :: BuiltinBuilder
361 genResize = genNoInsts $ genExprArgs $ genExprRes genResize'
362 genResize' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession AST.Expr
363 genResize' (Left res) f [arg] = do {
364 ; let { ty = Var.varType res
365 ; (tycon, args) = Type.splitTyConApp ty
366 ; name = Name.getOccString (TyCon.tyConName tycon)
368 ; len <- case name of
369 "SizedInt" -> MonadState.lift tsType $ tfp_to_int (sized_int_len_ty ty)
370 "SizedWord" -> MonadState.lift tsType $ tfp_to_int (sized_word_len_ty ty)
371 ; return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId resizeId))
372 [Nothing AST.:=>: AST.ADExpr arg, Nothing AST.:=>: AST.ADExpr( AST.PrimLit (show len))]
374 genResize' (Right name) _ _ = error $ "\nGenerate.genFromSizedWord': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
376 -- FIXME: I'm calling genLitArgs which is very specific function,
377 -- which needs to be fixed as well
378 genFromInteger :: BuiltinBuilder
379 genFromInteger = genNoInsts $ genLitArgs $ genExprRes genFromInteger'
380 genFromInteger' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [Literal.Literal] -> TranslatorSession AST.Expr
381 genFromInteger' (Left res) f lits = do {
382 ; let { ty = Var.varType res
383 ; (tycon, args) = Type.splitTyConApp ty
384 ; name = Name.getOccString (TyCon.tyConName tycon)
386 ; len <- case name of
387 "SizedInt" -> MonadState.lift tsType $ tfp_to_int (sized_int_len_ty ty)
388 "SizedWord" -> MonadState.lift tsType $ tfp_to_int (sized_word_len_ty ty)
390 ; bound <- MonadState.lift tsType $ tfp_to_int (ranged_word_bound_ty ty)
391 ; return $ floor (logBase 2 (fromInteger (toInteger (bound)))) + 1
393 ; let fname = case name of "SizedInt" -> toSignedId ; "SizedWord" -> toUnsignedId ; "RangedWord" -> toUnsignedId
394 ; return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId fname))
395 [Nothing AST.:=>: AST.ADExpr (AST.PrimLit (show (last lits))), Nothing AST.:=>: AST.ADExpr( AST.PrimLit (show len))]
399 genFromInteger' (Right name) _ _ = error $ "\nGenerate.genFromInteger': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
401 genSizedInt :: BuiltinBuilder
402 genSizedInt = genFromInteger
405 -- | Generate a Builder for the builtin datacon TFVec
406 genTFVec :: BuiltinBuilder
407 genTFVec (Left res) f [Left (CoreSyn.Let (CoreSyn.Rec letBinders) letRes)] = do {
408 -- Generate Assignments for all the binders
409 ; letAssigns <- mapM genBinderAssign letBinders
410 -- Generate assignments for the result (which might be another let binding)
411 ; (resBinders,resAssignments) <- genResAssign letRes
412 -- Get all the Assigned binders
413 ; let assignedBinders = Maybe.catMaybes (map fst letAssigns)
414 -- Make signal names for all the assigned binders
415 ; sigs <- mapM (\x -> MonadState.lift tsType $ varToVHDLExpr x) (assignedBinders ++ resBinders)
416 -- Assign all the signals to the resulting vector
417 ; let { vecsigns = mkAggregateSignal sigs
418 ; vecassign = mkUncondAssign (Left res) vecsigns
420 -- Generate all the signal declaration for the assigned binders
421 ; sig_dec_maybes <- mapM mkSigDec (assignedBinders ++ resBinders)
422 ; let { sig_decs = map (AST.BDISD) (Maybe.catMaybes $ sig_dec_maybes)
423 -- Setup the VHDL Block
424 ; block_label = mkVHDLExtId ("TFVec_" ++ show (varToString res))
425 ; block = AST.BlockSm block_label [] (AST.PMapAspect []) sig_decs ((concat (map snd letAssigns)) ++ resAssignments ++ [vecassign])
427 -- Return the block statement coressponding to the TFVec literal
428 ; return $ [AST.CSBSm block]
431 genBinderAssign :: (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -> TranslatorSession (Maybe CoreSyn.CoreBndr, [AST.ConcSm])
432 -- For now we only translate applications
433 genBinderAssign (bndr, app@(CoreSyn.App _ _)) = do
434 let (CoreSyn.Var f, args) = CoreSyn.collectArgs app
435 let valargs = get_val_args (Var.varType f) args
436 apps <- genApplication (Left bndr) f (map Left valargs)
437 return (Just bndr, apps)
438 genBinderAssign _ = return (Nothing,[])
439 genResAssign :: CoreSyn.CoreExpr -> TranslatorSession ([CoreSyn.CoreBndr], [AST.ConcSm])
440 genResAssign app@(CoreSyn.App _ letexpr) = do
442 (CoreSyn.Let (CoreSyn.Rec letbndrs) letres) -> do
443 letapps <- mapM genBinderAssign letbndrs
444 let bndrs = Maybe.catMaybes (map fst letapps)
445 let app = (map snd letapps)
446 (vars, apps) <- genResAssign letres
447 return ((bndrs ++ vars),((concat app) ++ apps))
448 otherwise -> return ([],[])
449 genResAssign _ = return ([],[])
451 genTFVec (Left res) f [Left app@(CoreSyn.App _ _)] = do {
452 ; let { elems = reduceCoreListToHsList app
453 -- Make signal names for all the binders
454 ; binders = map (\expr -> case expr of
456 otherwise -> error $ "\nGenerate.genTFVec: Cannot generate TFVec: "
457 ++ show res ++ ", with elems:\n" ++ show elems ++ "\n" ++ pprString elems) elems
459 ; sigs <- mapM (\x -> MonadState.lift tsType $ varToVHDLExpr x) binders
460 -- Assign all the signals to the resulting vector
461 ; let { vecsigns = mkAggregateSignal sigs
462 ; vecassign = mkUncondAssign (Left res) vecsigns
463 -- Setup the VHDL Block
464 ; block_label = mkVHDLExtId ("TFVec_" ++ show (varToString res))
465 ; block = AST.BlockSm block_label [] (AST.PMapAspect []) [] [vecassign]
467 -- Return the block statement coressponding to the TFVec literal
468 ; return $ [AST.CSBSm block]
471 genTFVec (Left name) _ [Left xs] = error $ "\nGenerate.genTFVec: Cannot generate TFVec: " ++ show name ++ ", with elems:\n" ++ show xs ++ "\n" ++ pprString xs
473 genTFVec (Right name) _ _ = error $ "\nGenerate.genTFVec: Cannot generate TFVec assigned to VHDLName: " ++ show name
475 -- | Generate a generate statement for the builtin function "map"
476 genMap :: BuiltinBuilder
477 genMap (Left res) f [Left mapped_f, Left (CoreSyn.Var arg)] = do {
478 -- mapped_f must be a CoreExpr (since we can't represent functions as VHDL
479 -- expressions). arg must be a CoreExpr (and should be a CoreSyn.Var), since
480 -- we must index it (which we couldn't if it was a VHDL Expr, since only
481 -- VHDLNames can be indexed).
482 -- Setup the generate scheme
483 ; len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) res
484 -- TODO: Use something better than varToString
485 ; let { label = mkVHDLExtId ("mapVector" ++ (varToString res))
486 ; n_id = mkVHDLBasicId "n"
487 ; n_expr = idToVHDLExpr n_id
488 ; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
489 ; genScheme = AST.ForGn n_id range
490 -- Create the content of the generate statement: Applying the mapped_f to
491 -- each of the elements in arg, storing to each element in res
492 ; resname = mkIndexedName (varToVHDLName res) n_expr
493 ; argexpr = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg) n_expr
494 ; (CoreSyn.Var real_f, already_mapped_args) = CoreSyn.collectArgs mapped_f
495 ; valargs = get_val_args (Var.varType real_f) already_mapped_args
497 ; (app_concsms, used) <- genApplication (Right resname) real_f (map Left valargs ++ [Right argexpr])
498 -- Return the generate statement
499 ; return ([AST.CSGSm $ AST.GenerateSm label genScheme [] app_concsms], used)
502 genMap' (Right name) _ _ = error $ "\nGenerate.genMap': Cannot generate map function call assigned to a VHDLName: " ++ show name
504 genZipWith :: BuiltinBuilder
505 genZipWith = genVarArgs genZipWith'
506 genZipWith' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
507 genZipWith' (Left res) f args@[zipped_f, arg1, arg2] = do {
508 -- Setup the generate scheme
509 ; len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) res
510 -- TODO: Use something better than varToString
511 ; let { label = mkVHDLExtId ("zipWithVector" ++ (varToString res))
512 ; n_id = mkVHDLBasicId "n"
513 ; n_expr = idToVHDLExpr n_id
514 ; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
515 ; genScheme = AST.ForGn n_id range
516 -- Create the content of the generate statement: Applying the zipped_f to
517 -- each of the elements in arg1 and arg2, storing to each element in res
518 ; resname = mkIndexedName (varToVHDLName res) n_expr
519 ; argexpr1 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg1) n_expr
520 ; argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg2) n_expr
522 ; (app_concsms, used) <- genApplication (Right resname) zipped_f [Right argexpr1, Right argexpr2]
523 -- Return the generate functions
524 ; return ([AST.CSGSm $ AST.GenerateSm label genScheme [] app_concsms], used)
527 genFoldl :: BuiltinBuilder
528 genFoldl = genFold True
530 genFoldr :: BuiltinBuilder
531 genFoldr = genFold False
533 genFold :: Bool -> BuiltinBuilder
534 genFold left = genVarArgs (genFold' left)
536 genFold' :: Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
537 genFold' left res f args@[folded_f , start ,vec]= do
538 len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty (Var.varType vec))
539 genFold'' len left res f args
541 genFold'' :: Int -> Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
542 -- Special case for an empty input vector, just assign start to res
543 genFold'' len left (Left res) _ [_, start, vec] | len == 0 = do
544 arg <- MonadState.lift tsType $ varToVHDLExpr start
545 return ([mkUncondAssign (Left res) arg], [])
547 genFold'' len left (Left res) f [folded_f, start, vec] = do
549 --len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) vec
550 -- An expression for len-1
551 let len_min_expr = (AST.PrimLit $ show (len-1))
552 -- evec is (TFVec n), so it still needs an element type
553 let (nvec, _) = Type.splitAppTy (Var.varType vec)
554 -- Put the type of the start value in nvec, this will be the type of our
556 let tmp_ty = Type.mkAppTy nvec (Var.varType start)
557 let error_msg = "\nGenerate.genFold': Can not construct temp vector for element type: " ++ pprString tmp_ty
558 -- TODO: Handle Nothing
559 Just tmp_vhdl_ty <- MonadState.lift tsType $ vhdl_ty error_msg tmp_ty
560 -- Setup the generate scheme
561 let gen_label = mkVHDLExtId ("foldlVector" ++ (varToString vec))
562 let block_label = mkVHDLExtId ("foldlVector" ++ (varToString res))
563 let gen_range = if left then AST.ToRange (AST.PrimLit "0") len_min_expr
564 else AST.DownRange len_min_expr (AST.PrimLit "0")
565 let gen_scheme = AST.ForGn n_id gen_range
566 -- Make the intermediate vector
567 let tmp_dec = AST.BDISD $ AST.SigDec tmp_id tmp_vhdl_ty Nothing
568 -- Create the generate statement
569 cells' <- sequence [genFirstCell, genOtherCell]
570 let (cells, useds) = unzip cells'
571 let gen_sm = AST.GenerateSm gen_label gen_scheme [] (map AST.CSGSm cells)
572 -- Assign tmp[len-1] or tmp[0] to res
573 let out_assign = mkUncondAssign (Left res) $ vhdlNameToVHDLExpr (if left then
574 (mkIndexedName tmp_name (AST.PrimLit $ show (len-1))) else
575 (mkIndexedName tmp_name (AST.PrimLit "0")))
576 let block = AST.BlockSm block_label [] (AST.PMapAspect []) [tmp_dec] [AST.CSGSm gen_sm, out_assign]
577 return ([AST.CSBSm block], concat useds)
579 -- An id for the counter
580 n_id = mkVHDLBasicId "n"
581 n_cur = idToVHDLExpr n_id
582 -- An expression for previous n
583 n_prev = if left then (n_cur AST.:-: (AST.PrimLit "1"))
584 else (n_cur AST.:+: (AST.PrimLit "1"))
585 -- An id for the tmp result vector
586 tmp_id = mkVHDLBasicId "tmp"
587 tmp_name = AST.NSimple tmp_id
588 -- Generate parts of the fold
589 genFirstCell, genOtherCell :: TranslatorSession (AST.GenerateSm, [CoreSyn.CoreBndr])
591 len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) vec
592 let cond_label = mkVHDLExtId "firstcell"
593 -- if n == 0 or n == len-1
594 let cond_scheme = AST.IfGn $ n_cur AST.:=: (if left then (AST.PrimLit "0")
595 else (AST.PrimLit $ show (len-1)))
596 -- Output to tmp[current n]
597 let resname = mkIndexedName tmp_name n_cur
599 argexpr1 <- MonadState.lift tsType $ varToVHDLExpr start
600 -- Input from vec[current n]
601 let argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName vec) n_cur
602 (app_concsms, used) <- genApplication (Right resname) folded_f ( if left then
603 [Right argexpr1, Right argexpr2]
605 [Right argexpr2, Right argexpr1]
607 -- Return the conditional generate part
608 return $ (AST.GenerateSm cond_label cond_scheme [] app_concsms, used)
611 len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) vec
612 let cond_label = mkVHDLExtId "othercell"
613 -- if n > 0 or n < len-1
614 let cond_scheme = AST.IfGn $ n_cur AST.:/=: (if left then (AST.PrimLit "0")
615 else (AST.PrimLit $ show (len-1)))
616 -- Output to tmp[current n]
617 let resname = mkIndexedName tmp_name n_cur
618 -- Input from tmp[previous n]
619 let argexpr1 = vhdlNameToVHDLExpr $ mkIndexedName tmp_name n_prev
620 -- Input from vec[current n]
621 let argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName vec) n_cur
622 (app_concsms, used) <- genApplication (Right resname) folded_f ( if left then
623 [Right argexpr1, Right argexpr2]
625 [Right argexpr2, Right argexpr1]
627 -- Return the conditional generate part
628 return $ (AST.GenerateSm cond_label cond_scheme [] app_concsms, used)
630 -- | Generate a generate statement for the builtin function "zip"
631 genZip :: BuiltinBuilder
632 genZip = genNoInsts $ genVarArgs genZip'
633 genZip' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession [AST.ConcSm]
634 genZip' (Left res) f args@[arg1, arg2] = do {
635 -- Setup the generate scheme
636 ; len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) res
637 -- TODO: Use something better than varToString
638 ; let { label = mkVHDLExtId ("zipVector" ++ (varToString res))
639 ; n_id = mkVHDLBasicId "n"
640 ; n_expr = idToVHDLExpr n_id
641 ; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
642 ; genScheme = AST.ForGn n_id range
643 ; resname' = mkIndexedName (varToVHDLName res) n_expr
644 ; argexpr1 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg1) n_expr
645 ; argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg2) n_expr
647 ; labels <- MonadState.lift tsType $ getFieldLabels (tfvec_elem (Var.varType res))
648 ; let { resnameA = mkSelectedName resname' (labels!!0)
649 ; resnameB = mkSelectedName resname' (labels!!1)
650 ; resA_assign = mkUncondAssign (Right resnameA) argexpr1
651 ; resB_assign = mkUncondAssign (Right resnameB) argexpr2
653 -- Return the generate functions
654 ; return [AST.CSGSm $ AST.GenerateSm label genScheme [] [resA_assign,resB_assign]]
657 -- | Generate a generate statement for the builtin function "fst"
658 genFst :: BuiltinBuilder
659 genFst = genNoInsts $ genVarArgs genFst'
660 genFst' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession [AST.ConcSm]
661 genFst' (Left res) f args@[arg] = do {
662 ; labels <- MonadState.lift tsType $ getFieldLabels (Var.varType arg)
663 ; let { argexpr' = varToVHDLName arg
664 ; argexprA = vhdlNameToVHDLExpr $ mkSelectedName argexpr' (labels!!0)
665 ; assign = mkUncondAssign (Left res) argexprA
667 -- Return the generate functions
671 -- | Generate a generate statement for the builtin function "snd"
672 genSnd :: BuiltinBuilder
673 genSnd = genNoInsts $ genVarArgs genSnd'
674 genSnd' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession [AST.ConcSm]
675 genSnd' (Left res) f args@[arg] = do {
676 ; labels <- MonadState.lift tsType $ getFieldLabels (Var.varType arg)
677 ; let { argexpr' = varToVHDLName arg
678 ; argexprB = vhdlNameToVHDLExpr $ mkSelectedName argexpr' (labels!!1)
679 ; assign = mkUncondAssign (Left res) argexprB
681 -- Return the generate functions
685 -- | Generate a generate statement for the builtin function "unzip"
686 genUnzip :: BuiltinBuilder
687 genUnzip = genNoInsts $ genVarArgs genUnzip'
688 genUnzip' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession [AST.ConcSm]
689 genUnzip' (Left res) f args@[arg] = do {
690 -- Setup the generate scheme
691 ; len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) arg
692 -- TODO: Use something better than varToString
693 ; let { label = mkVHDLExtId ("unzipVector" ++ (varToString res))
694 ; n_id = mkVHDLBasicId "n"
695 ; n_expr = idToVHDLExpr n_id
696 ; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
697 ; genScheme = AST.ForGn n_id range
698 ; resname' = varToVHDLName res
699 ; argexpr' = mkIndexedName (varToVHDLName arg) n_expr
701 ; reslabels <- MonadState.lift tsType $ getFieldLabels (Var.varType res)
702 ; arglabels <- MonadState.lift tsType $ getFieldLabels (tfvec_elem (Var.varType arg))
703 ; let { resnameA = mkIndexedName (mkSelectedName resname' (reslabels!!0)) n_expr
704 ; resnameB = mkIndexedName (mkSelectedName resname' (reslabels!!1)) n_expr
705 ; argexprA = vhdlNameToVHDLExpr $ mkSelectedName argexpr' (arglabels!!0)
706 ; argexprB = vhdlNameToVHDLExpr $ mkSelectedName argexpr' (arglabels!!1)
707 ; resA_assign = mkUncondAssign (Right resnameA) argexprA
708 ; resB_assign = mkUncondAssign (Right resnameB) argexprB
710 -- Return the generate functions
711 ; return [AST.CSGSm $ AST.GenerateSm label genScheme [] [resA_assign,resB_assign]]
714 genCopy :: BuiltinBuilder
715 genCopy = genNoInsts $ genVarArgs genCopy'
716 genCopy' :: (Either CoreSyn.CoreBndr AST.VHDLName ) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession [AST.ConcSm]
717 genCopy' (Left res) f args@[arg] =
719 resExpr = AST.Aggregate [AST.ElemAssoc (Just AST.Others)
720 (AST.PrimName $ (varToVHDLName arg))]
721 out_assign = mkUncondAssign (Left res) resExpr
725 genConcat :: BuiltinBuilder
726 genConcat = genNoInsts $ genVarArgs genConcat'
727 genConcat' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession [AST.ConcSm]
728 genConcat' (Left res) f args@[arg] = do {
729 -- Setup the generate scheme
730 ; len1 <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) arg
731 ; let (_, nvec) = Type.splitAppTy (Var.varType arg)
732 ; len2 <- MonadState.lift tsType $ tfp_to_int $ tfvec_len_ty nvec
733 -- TODO: Use something better than varToString
734 ; let { label = mkVHDLExtId ("concatVector" ++ (varToString res))
735 ; n_id = mkVHDLBasicId "n"
736 ; n_expr = idToVHDLExpr n_id
737 ; fromRange = n_expr AST.:*: (AST.PrimLit $ show len2)
738 ; genScheme = AST.ForGn n_id range
739 -- Create the content of the generate statement: Applying the mapped_f to
740 -- each of the elements in arg, storing to each element in res
741 ; toRange = (n_expr AST.:*: (AST.PrimLit $ show len2)) AST.:+: (AST.PrimLit $ show (len2-1))
742 ; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len1-1))
743 ; resname = vecSlice fromRange toRange
744 ; argexpr = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg) n_expr
745 ; out_assign = mkUncondAssign (Right resname) argexpr
747 -- Return the generate statement
748 ; return [AST.CSGSm $ AST.GenerateSm label genScheme [] [out_assign]]
751 vecSlice init last = AST.NSlice (AST.SliceName (varToVHDLName res)
752 (AST.ToRange init last))
754 genIteraten :: BuiltinBuilder
755 genIteraten dst f args = genIterate dst f (tail args)
757 genIterate :: BuiltinBuilder
758 genIterate = genIterateOrGenerate True
760 genGeneraten :: BuiltinBuilder
761 genGeneraten dst f args = genGenerate dst f (tail args)
763 genGenerate :: BuiltinBuilder
764 genGenerate = genIterateOrGenerate False
766 genIterateOrGenerate :: Bool -> BuiltinBuilder
767 genIterateOrGenerate iter = genVarArgs (genIterateOrGenerate' iter)
769 genIterateOrGenerate' :: Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
770 genIterateOrGenerate' iter (Left res) f args = do
771 len <- MonadState.lift tsType $ tfp_to_int ((tfvec_len_ty . Var.varType) res)
772 genIterateOrGenerate'' len iter (Left res) f args
774 genIterateOrGenerate'' :: Int -> Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
775 -- Special case for an empty input vector, just assign start to res
776 genIterateOrGenerate'' len iter (Left res) _ [app_f, start] | len == 0 = return ([mkUncondAssign (Left res) (AST.PrimLit "\"\"")], [])
778 genIterateOrGenerate'' len iter (Left res) f [app_f, start] = do
780 -- len <- MonadState.lift tsType $ tfp_to_int ((tfvec_len_ty . Var.varType) res)
781 -- An expression for len-1
782 let len_min_expr = (AST.PrimLit $ show (len-1))
783 -- -- evec is (TFVec n), so it still needs an element type
784 -- let (nvec, _) = splitAppTy (Var.varType vec)
785 -- -- Put the type of the start value in nvec, this will be the type of our
786 -- -- temporary vector
787 let tmp_ty = Var.varType res
788 let error_msg = "\nGenerate.genFold': Can not construct temp vector for element type: " ++ pprString tmp_ty
789 -- TODO: Handle Nothing
790 Just tmp_vhdl_ty <- MonadState.lift tsType $ vhdl_ty error_msg tmp_ty
791 -- Setup the generate scheme
792 let gen_label = mkVHDLExtId ("iterateVector" ++ (varToString start))
793 let block_label = mkVHDLExtId ("iterateVector" ++ (varToString res))
794 let gen_range = AST.ToRange (AST.PrimLit "0") len_min_expr
795 let gen_scheme = AST.ForGn n_id gen_range
796 -- Make the intermediate vector
797 let tmp_dec = AST.BDISD $ AST.SigDec tmp_id tmp_vhdl_ty Nothing
798 -- Create the generate statement
799 cells' <- sequence [genFirstCell, genOtherCell]
800 let (cells, useds) = unzip cells'
801 let gen_sm = AST.GenerateSm gen_label gen_scheme [] (map AST.CSGSm cells)
802 -- Assign tmp[len-1] or tmp[0] to res
803 let out_assign = mkUncondAssign (Left res) $ vhdlNameToVHDLExpr tmp_name
804 let block = AST.BlockSm block_label [] (AST.PMapAspect []) [tmp_dec] [AST.CSGSm gen_sm, out_assign]
805 return ([AST.CSBSm block], concat useds)
807 -- An id for the counter
808 n_id = mkVHDLBasicId "n"
809 n_cur = idToVHDLExpr n_id
810 -- An expression for previous n
811 n_prev = n_cur AST.:-: (AST.PrimLit "1")
812 -- An id for the tmp result vector
813 tmp_id = mkVHDLBasicId "tmp"
814 tmp_name = AST.NSimple tmp_id
815 -- Generate parts of the fold
816 genFirstCell, genOtherCell :: TranslatorSession (AST.GenerateSm, [CoreSyn.CoreBndr])
818 let cond_label = mkVHDLExtId "firstcell"
819 -- if n == 0 or n == len-1
820 let cond_scheme = AST.IfGn $ n_cur AST.:=: (AST.PrimLit "0")
821 -- Output to tmp[current n]
822 let resname = mkIndexedName tmp_name n_cur
824 argexpr <- MonadState.lift tsType $ varToVHDLExpr start
825 let startassign = mkUncondAssign (Right resname) argexpr
826 (app_concsms, used) <- genApplication (Right resname) app_f [Right argexpr]
827 -- Return the conditional generate part
828 let gensm = AST.GenerateSm cond_label cond_scheme [] (if iter then
836 let cond_label = mkVHDLExtId "othercell"
837 -- if n > 0 or n < len-1
838 let cond_scheme = AST.IfGn $ n_cur AST.:/=: (AST.PrimLit "0")
839 -- Output to tmp[current n]
840 let resname = mkIndexedName tmp_name n_cur
841 -- Input from tmp[previous n]
842 let argexpr = vhdlNameToVHDLExpr $ mkIndexedName tmp_name n_prev
843 (app_concsms, used) <- genApplication (Right resname) app_f [Right argexpr]
844 -- Return the conditional generate part
845 return $ (AST.GenerateSm cond_label cond_scheme [] app_concsms, used)
847 genBlockRAM :: BuiltinBuilder
848 genBlockRAM = genNoInsts $ genExprArgs genBlockRAM'
850 genBlockRAM' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession [AST.ConcSm]
851 genBlockRAM' (Left res) f args@[data_in,rdaddr,wraddr,wrenable] = do
853 let (tup,data_out) = Type.splitAppTy (Var.varType res)
854 let (tup',ramvec) = Type.splitAppTy tup
855 let Just realram = Type.coreView ramvec
856 let Just (tycon, types) = Type.splitTyConApp_maybe realram
857 Just ram_vhdl_ty <- MonadState.lift tsType $ vhdl_ty "wtf" (head types)
858 -- Make the intermediate vector
859 let ram_dec = AST.BDISD $ AST.SigDec ram_id ram_vhdl_ty Nothing
860 -- Get the data_out name
861 reslabels <- MonadState.lift tsType $ getFieldLabels (Var.varType res)
862 let resname' = varToVHDLName res
863 let resname = mkSelectedName resname' (reslabels!!0)
864 let rdaddr_int = genExprFCall (mkVHDLBasicId toIntegerId) rdaddr
865 let argexpr = vhdlNameToVHDLExpr $ mkIndexedName (AST.NSimple ram_id) rdaddr_int
866 let assign = mkUncondAssign (Right resname) argexpr
867 let block_label = mkVHDLExtId ("blockRAM" ++ (varToString res))
868 let block = AST.BlockSm block_label [] (AST.PMapAspect []) [ram_dec] [assign, mkUpdateProcSm]
869 return [AST.CSBSm block]
871 ram_id = mkVHDLBasicId "ram"
872 mkUpdateProcSm :: AST.ConcSm
873 mkUpdateProcSm = AST.CSPSm $ AST.ProcSm proclabel [clockId] [statement]
875 proclabel = mkVHDLBasicId "updateRAM"
876 rising_edge = mkVHDLBasicId "rising_edge"
877 wraddr_int = genExprFCall (mkVHDLBasicId toIntegerId) wraddr
878 ramloc = mkIndexedName (AST.NSimple ram_id) wraddr_int
879 wform = AST.Wform [AST.WformElem data_in Nothing]
880 ramassign = AST.SigAssign ramloc wform
881 rising_edge_clk = genExprFCall rising_edge (AST.PrimName $ AST.NSimple clockId)
882 statement = AST.IfSm (AST.And rising_edge_clk (wrenable AST.:=: AST.PrimLit "'1'")) [ramassign] [] Nothing
884 -----------------------------------------------------------------------------
885 -- Function to generate VHDL for applications
886 -----------------------------------------------------------------------------
888 (Either CoreSyn.CoreBndr AST.VHDLName) -- ^ Where to store the result?
889 -> CoreSyn.CoreBndr -- ^ The function to apply
890 -> [Either CoreSyn.CoreExpr AST.Expr] -- ^ The arguments to apply
891 -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
892 -- ^ The corresponding VHDL concurrent statements and entities
894 genApplication dst f args = do
895 case Var.isGlobalId f of
897 top <- isTopLevelBinder f
900 -- Local binder that references a top level binding. Generate a
901 -- component instantiation.
902 signature <- getEntity f
903 args' <- argsToVHDLExprs args
904 let entity_id = ent_id signature
905 -- TODO: Using show here isn't really pretty, but we'll need some
906 -- unique-ish value...
907 let label = "comp_ins_" ++ (either (prettyShow . varToVHDLName) prettyShow) dst
908 let portmaps = mkAssocElems args' ((either varToVHDLName id) dst) signature
909 return ([mkComponentInst label entity_id portmaps], [f])
911 -- Not a top level binder, so this must be a local variable reference.
912 -- It should have a representable type (and thus, no arguments) and a
913 -- signal should be generated for it. Just generate an unconditional
915 f' <- MonadState.lift tsType $ varToVHDLExpr f
916 return $ ([mkUncondAssign dst f'], [])
918 case Var.idDetails f of
919 IdInfo.DataConWorkId dc -> case dst of
920 -- It's a datacon. Create a record from its arguments.
922 -- We have the bndr, so we can get at the type
923 labels <- MonadState.lift tsType $ getFieldLabels (Var.varType bndr)
924 args' <- argsToVHDLExprs args
925 return $ (zipWith mkassign labels $ args', [])
927 mkassign :: AST.VHDLId -> AST.Expr -> AST.ConcSm
929 let sel_name = mkSelectedName ((either varToVHDLName id) dst) label in
930 mkUncondAssign (Right sel_name) arg
931 Right _ -> error $ "\nGenerate.genApplication: Can't generate dataconstructor application without an original binder"
932 IdInfo.DataConWrapId dc -> case dst of
933 -- It's a datacon. Create a record from its arguments.
935 case (Map.lookup (varToString f) globalNameTable) of
936 Just (arg_count, builder) ->
937 if length args == arg_count then
940 error $ "\nGenerate.genApplication(DataConWrapId): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args
941 Nothing -> error $ "\nGenerate.genApplication: Can't generate dataconwrapper: " ++ (show dc)
942 Right _ -> error $ "\nGenerate.genApplication: Can't generate dataconwrapper application without an original binder"
943 IdInfo.VanillaId -> do
944 -- It's a global value imported from elsewhere. These can be builtin
945 -- functions. Look up the function name in the name table and execute
946 -- the associated builder if there is any and the argument count matches
947 -- (this should always be the case if it typechecks, but just to be
949 case (Map.lookup (varToString f) globalNameTable) of
950 Just (arg_count, builder) ->
951 if length args == arg_count then
954 error $ "\nGenerate.genApplication(VanillaId): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args
956 top <- isTopLevelBinder f
959 -- Local binder that references a top level binding. Generate a
960 -- component instantiation.
961 signature <- getEntity f
962 args' <- argsToVHDLExprs args
963 let entity_id = ent_id signature
964 -- TODO: Using show here isn't really pretty, but we'll need some
965 -- unique-ish value...
966 let label = "comp_ins_" ++ (either show prettyShow) dst
967 let portmaps = mkAssocElems args' ((either varToVHDLName id) dst) signature
968 return ([mkComponentInst label entity_id portmaps], [f])
970 -- Not a top level binder, so this must be a local variable reference.
971 -- It should have a representable type (and thus, no arguments) and a
972 -- signal should be generated for it. Just generate an unconditional
974 -- FIXME : I DONT KNOW IF THE ABOVE COMMENT HOLDS HERE, SO FOR NOW JUST ERROR!
975 -- f' <- MonadState.lift tsType $ varToVHDLExpr f
976 -- return $ ([mkUncondAssign dst f'], [])
977 error $ ("\nGenerate.genApplication(VanillaId): Using function from another module that is not a known builtin: " ++ (pprString f))
978 IdInfo.ClassOpId cls -> do
979 -- FIXME: Not looking for what instance this class op is called for
980 -- Is quite stupid of course.
981 case (Map.lookup (varToString f) globalNameTable) of
982 Just (arg_count, builder) ->
983 if length args == arg_count then
986 error $ "\nGenerate.genApplication(ClassOpId): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args
987 Nothing -> error $ "\nGenerate.genApplication(ClassOpId): Using function from another module that is not a known builtin: " ++ pprString f
988 details -> error $ "\nGenerate.genApplication: Calling unsupported function " ++ pprString f ++ " with GlobalIdDetails " ++ pprString details
990 -----------------------------------------------------------------------------
991 -- Functions to generate functions dealing with vectors.
992 -----------------------------------------------------------------------------
994 -- Returns the VHDLId of the vector function with the given name for the given
995 -- element type. Generates -- this function if needed.
996 vectorFunId :: Type.Type -> String -> TypeSession AST.VHDLId
997 vectorFunId el_ty fname = do
998 let error_msg = "\nGenerate.vectorFunId: Can not construct vector function for element: " ++ pprString el_ty
999 -- TODO: Handle the Nothing case?
1000 Just elemTM <- vhdl_ty error_msg el_ty
1001 -- TODO: This should not be duplicated from mk_vector_ty. Probably but it in
1002 -- the VHDLState or something.
1003 let vectorTM = mkVHDLExtId $ "vector_" ++ (AST.fromVHDLId elemTM)
1004 typefuns <- getA tsTypeFuns
1005 case Map.lookup (OrdType el_ty, fname) typefuns of
1006 -- Function already generated, just return it
1007 Just (id, _) -> return id
1008 -- Function not generated yet, generate it
1010 let functions = genUnconsVectorFuns elemTM vectorTM
1011 case lookup fname functions of
1013 modA tsTypeFuns $ Map.insert (OrdType el_ty, fname) (function_id, (fst body))
1014 mapM_ (vectorFunId el_ty) (snd body)
1016 Nothing -> error $ "\nGenerate.vectorFunId: I don't know how to generate vector function " ++ fname
1018 function_id = mkVHDLExtId fname
1020 genUnconsVectorFuns :: AST.TypeMark -- ^ type of the vector elements
1021 -> AST.TypeMark -- ^ type of the vector
1022 -> [(String, (AST.SubProgBody, [String]))]
1023 genUnconsVectorFuns elemTM vectorTM =
1024 [ (exId, (AST.SubProgBody exSpec [] [exExpr],[]))
1025 , (replaceId, (AST.SubProgBody replaceSpec [AST.SPVD replaceVar] [replaceExpr1,replaceExpr2,replaceRet],[]))
1026 , (lastId, (AST.SubProgBody lastSpec [] [lastExpr],[]))
1027 , (initId, (AST.SubProgBody initSpec [AST.SPVD initVar] [initExpr, initRet],[]))
1028 , (minimumId, (AST.SubProgBody minimumSpec [] [minimumExpr],[]))
1029 , (takeId, (AST.SubProgBody takeSpec [AST.SPVD takeVar] [takeExpr, takeRet],[minimumId]))
1030 , (dropId, (AST.SubProgBody dropSpec [AST.SPVD dropVar] [dropExpr, dropRet],[]))
1031 , (plusgtId, (AST.SubProgBody plusgtSpec [AST.SPVD plusgtVar] [plusgtExpr, plusgtRet],[]))
1032 , (emptyId, (AST.SubProgBody emptySpec [AST.SPVD emptyVar] [emptyExpr],[]))
1033 , (singletonId, (AST.SubProgBody singletonSpec [AST.SPVD singletonVar] [singletonRet],[]))
1034 , (copynId, (AST.SubProgBody copynSpec [AST.SPVD copynVar] [copynExpr],[]))
1035 , (selId, (AST.SubProgBody selSpec [AST.SPVD selVar] [selFor, selRet],[]))
1036 , (ltplusId, (AST.SubProgBody ltplusSpec [AST.SPVD ltplusVar] [ltplusExpr, ltplusRet],[]))
1037 , (plusplusId, (AST.SubProgBody plusplusSpec [AST.SPVD plusplusVar] [plusplusExpr, plusplusRet],[]))
1038 , (lengthTId, (AST.SubProgBody lengthTSpec [] [lengthTExpr],[]))
1039 , (shiftlId, (AST.SubProgBody shiftlSpec [AST.SPVD shiftlVar] [shiftlExpr, shiftlRet], [initId]))
1040 , (shiftrId, (AST.SubProgBody shiftrSpec [AST.SPVD shiftrVar] [shiftrExpr, shiftrRet], [tailId]))
1041 , (nullId, (AST.SubProgBody nullSpec [] [nullExpr], []))
1042 , (rotlId, (AST.SubProgBody rotlSpec [AST.SPVD rotlVar] [rotlExpr, rotlRet], [nullId, lastId, initId]))
1043 , (rotrId, (AST.SubProgBody rotrSpec [AST.SPVD rotrVar] [rotrExpr, rotrRet], [nullId, tailId, headId]))
1044 , (reverseId, (AST.SubProgBody reverseSpec [AST.SPVD reverseVar] [reverseFor, reverseRet], []))
1047 ixPar = AST.unsafeVHDLBasicId "ix"
1048 vecPar = AST.unsafeVHDLBasicId "vec"
1049 vec1Par = AST.unsafeVHDLBasicId "vec1"
1050 vec2Par = AST.unsafeVHDLBasicId "vec2"
1051 nPar = AST.unsafeVHDLBasicId "n"
1052 leftPar = AST.unsafeVHDLBasicId "nLeft"
1053 rightPar = AST.unsafeVHDLBasicId "nRight"
1054 iId = AST.unsafeVHDLBasicId "i"
1056 aPar = AST.unsafeVHDLBasicId "a"
1057 fPar = AST.unsafeVHDLBasicId "f"
1058 sPar = AST.unsafeVHDLBasicId "s"
1059 resId = AST.unsafeVHDLBasicId "res"
1060 exSpec = AST.Function (mkVHDLExtId exId) [AST.IfaceVarDec vecPar vectorTM,
1061 AST.IfaceVarDec ixPar unsignedTM] elemTM
1062 exExpr = AST.ReturnSm (Just $ AST.PrimName $ AST.NIndexed
1063 (AST.IndexedName (AST.NSimple vecPar) [genExprFCall (mkVHDLBasicId toIntegerId) (AST.PrimName $ AST.NSimple $ ixPar)]))
1064 replaceSpec = AST.Function (mkVHDLExtId replaceId) [ AST.IfaceVarDec vecPar vectorTM
1065 , AST.IfaceVarDec iPar unsignedTM
1066 , AST.IfaceVarDec aPar elemTM
1068 -- variable res : fsvec_x (0 to vec'length-1);
1071 (AST.SubtypeIn vectorTM
1072 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1073 [AST.ToRange (AST.PrimLit "0")
1074 (AST.PrimName (AST.NAttribute $
1075 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1076 (AST.PrimLit "1")) ]))
1078 -- res AST.:= vec(0 to i-1) & a & vec(i+1 to length'vec-1)
1079 replaceExpr1 = AST.NSimple resId AST.:= AST.PrimName (AST.NSimple vecPar)
1080 replaceExpr2 = AST.NIndexed (AST.IndexedName (AST.NSimple resId) [genExprFCall (mkVHDLBasicId toIntegerId) (AST.PrimName $ AST.NSimple $ iPar)]) AST.:= AST.PrimName (AST.NSimple aPar)
1081 replaceRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1082 vecSlice init last = AST.PrimName (AST.NSlice
1084 (AST.NSimple vecPar)
1085 (AST.ToRange init last)))
1086 lastSpec = AST.Function (mkVHDLExtId lastId) [AST.IfaceVarDec vecPar vectorTM] elemTM
1087 -- return vec(vec'length-1);
1088 lastExpr = AST.ReturnSm (Just $ (AST.PrimName $ AST.NIndexed (AST.IndexedName
1089 (AST.NSimple vecPar)
1090 [AST.PrimName (AST.NAttribute $
1091 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing)
1092 AST.:-: AST.PrimLit "1"])))
1093 initSpec = AST.Function (mkVHDLExtId initId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
1094 -- variable res : fsvec_x (0 to vec'length-2);
1097 (AST.SubtypeIn vectorTM
1098 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1099 [AST.ToRange (AST.PrimLit "0")
1100 (AST.PrimName (AST.NAttribute $
1101 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1102 (AST.PrimLit "2")) ]))
1104 -- resAST.:= vec(0 to vec'length-2)
1105 initExpr = AST.NSimple resId AST.:= (vecSlice
1107 (AST.PrimName (AST.NAttribute $
1108 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing)
1109 AST.:-: AST.PrimLit "2"))
1110 initRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1111 minimumSpec = AST.Function (mkVHDLExtId minimumId) [AST.IfaceVarDec leftPar naturalTM,
1112 AST.IfaceVarDec rightPar naturalTM ] naturalTM
1113 minimumExpr = AST.IfSm ((AST.PrimName $ AST.NSimple leftPar) AST.:<: (AST.PrimName $ AST.NSimple rightPar))
1114 [AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple leftPar)]
1116 (Just $ AST.Else [minimumExprRet])
1117 where minimumExprRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple rightPar)
1118 takeSpec = AST.Function (mkVHDLExtId takeId) [AST.IfaceVarDec nPar naturalTM,
1119 AST.IfaceVarDec vecPar vectorTM ] vectorTM
1120 -- variable res : fsvec_x (0 to (minimum (n,vec'length))-1);
1121 minLength = AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId minimumId))
1122 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple nPar)
1123 ,Nothing AST.:=>: AST.ADExpr (AST.PrimName (AST.NAttribute $
1124 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))]
1127 (AST.SubtypeIn vectorTM
1128 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1129 [AST.ToRange (AST.PrimLit "0")
1131 (AST.PrimLit "1")) ]))
1133 -- res AST.:= vec(0 to n-1)
1134 takeExpr = AST.NSimple resId AST.:=
1135 (vecSlice (AST.PrimLit "0")
1136 (minLength AST.:-: AST.PrimLit "1"))
1137 takeRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1138 dropSpec = AST.Function (mkVHDLExtId dropId) [AST.IfaceVarDec nPar naturalTM,
1139 AST.IfaceVarDec vecPar vectorTM ] vectorTM
1140 -- variable res : fsvec_x (0 to vec'length-n-1);
1143 (AST.SubtypeIn vectorTM
1144 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1145 [AST.ToRange (AST.PrimLit "0")
1146 (AST.PrimName (AST.NAttribute $
1147 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1148 (AST.PrimName $ AST.NSimple nPar)AST.:-: (AST.PrimLit "1")) ]))
1150 -- res AST.:= vec(n to vec'length-1)
1151 dropExpr = AST.NSimple resId AST.:= (vecSlice
1152 (AST.PrimName $ AST.NSimple nPar)
1153 (AST.PrimName (AST.NAttribute $
1154 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing)
1155 AST.:-: AST.PrimLit "1"))
1156 dropRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1157 plusgtSpec = AST.Function (mkVHDLExtId plusgtId) [AST.IfaceVarDec aPar elemTM,
1158 AST.IfaceVarDec vecPar vectorTM] vectorTM
1159 -- variable res : fsvec_x (0 to vec'length);
1162 (AST.SubtypeIn vectorTM
1163 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1164 [AST.ToRange (AST.PrimLit "0")
1165 (AST.PrimName (AST.NAttribute $
1166 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))]))
1168 plusgtExpr = AST.NSimple resId AST.:=
1169 ((AST.PrimName $ AST.NSimple aPar) AST.:&:
1170 (AST.PrimName $ AST.NSimple vecPar))
1171 plusgtRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1172 emptySpec = AST.Function (mkVHDLExtId emptyId) [] vectorTM
1175 (AST.SubtypeIn vectorTM
1176 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1177 [AST.ToRange (AST.PrimLit "0") (AST.PrimLit "-1")]))
1179 emptyExpr = AST.ReturnSm (Just $ AST.PrimName (AST.NSimple resId))
1180 singletonSpec = AST.Function (mkVHDLExtId singletonId) [AST.IfaceVarDec aPar elemTM ]
1182 -- variable res : fsvec_x (0 to 0) := (others => a);
1185 (AST.SubtypeIn vectorTM
1186 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1187 [AST.ToRange (AST.PrimLit "0") (AST.PrimLit "0")]))
1188 (Just $ AST.Aggregate [AST.ElemAssoc (Just AST.Others)
1189 (AST.PrimName $ AST.NSimple aPar)])
1190 singletonRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1191 copynSpec = AST.Function (mkVHDLExtId copynId) [AST.IfaceVarDec nPar naturalTM,
1192 AST.IfaceVarDec aPar elemTM ] vectorTM
1193 -- variable res : fsvec_x (0 to n-1) := (others => a);
1196 (AST.SubtypeIn vectorTM
1197 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1198 [AST.ToRange (AST.PrimLit "0")
1199 ((AST.PrimName (AST.NSimple nPar)) AST.:-:
1200 (AST.PrimLit "1")) ]))
1201 (Just $ AST.Aggregate [AST.ElemAssoc (Just AST.Others)
1202 (AST.PrimName $ AST.NSimple aPar)])
1204 copynExpr = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1205 selSpec = AST.Function (mkVHDLExtId selId) [AST.IfaceVarDec fPar naturalTM,
1206 AST.IfaceVarDec sPar naturalTM,
1207 AST.IfaceVarDec nPar naturalTM,
1208 AST.IfaceVarDec vecPar vectorTM ] vectorTM
1209 -- variable res : fsvec_x (0 to n-1);
1212 (AST.SubtypeIn vectorTM
1213 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1214 [AST.ToRange (AST.PrimLit "0")
1215 ((AST.PrimName (AST.NSimple nPar)) AST.:-:
1216 (AST.PrimLit "1")) ])
1219 -- for i res'range loop
1220 -- res(i) := vec(f+i*s);
1222 selFor = AST.ForSM iId (AST.AttribRange $ AST.AttribName (AST.NSimple resId) (AST.NSimple $ rangeId) Nothing) [selAssign]
1223 -- res(i) := vec(f+i*s);
1224 selAssign = let origExp = AST.PrimName (AST.NSimple fPar) AST.:+:
1225 (AST.PrimName (AST.NSimple iId) AST.:*:
1226 AST.PrimName (AST.NSimple sPar)) in
1227 AST.NIndexed (AST.IndexedName (AST.NSimple resId) [AST.PrimName (AST.NSimple iId)]) AST.:=
1228 (AST.PrimName $ AST.NIndexed (AST.IndexedName (AST.NSimple vecPar) [origExp]))
1230 selRet = AST.ReturnSm (Just $ AST.PrimName (AST.NSimple resId))
1231 ltplusSpec = AST.Function (mkVHDLExtId ltplusId) [AST.IfaceVarDec vecPar vectorTM,
1232 AST.IfaceVarDec aPar elemTM] vectorTM
1233 -- variable res : fsvec_x (0 to vec'length);
1236 (AST.SubtypeIn vectorTM
1237 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1238 [AST.ToRange (AST.PrimLit "0")
1239 (AST.PrimName (AST.NAttribute $
1240 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))]))
1242 ltplusExpr = AST.NSimple resId AST.:=
1243 ((AST.PrimName $ AST.NSimple vecPar) AST.:&:
1244 (AST.PrimName $ AST.NSimple aPar))
1245 ltplusRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1246 plusplusSpec = AST.Function (mkVHDLExtId plusplusId) [AST.IfaceVarDec vec1Par vectorTM,
1247 AST.IfaceVarDec vec2Par vectorTM]
1249 -- variable res : fsvec_x (0 to vec1'length + vec2'length -1);
1252 (AST.SubtypeIn vectorTM
1253 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1254 [AST.ToRange (AST.PrimLit "0")
1255 (AST.PrimName (AST.NAttribute $
1256 AST.AttribName (AST.NSimple vec1Par) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:+:
1257 AST.PrimName (AST.NAttribute $
1258 AST.AttribName (AST.NSimple vec2Par) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1261 plusplusExpr = AST.NSimple resId AST.:=
1262 ((AST.PrimName $ AST.NSimple vec1Par) AST.:&:
1263 (AST.PrimName $ AST.NSimple vec2Par))
1264 plusplusRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1265 lengthTSpec = AST.Function (mkVHDLExtId lengthTId) [AST.IfaceVarDec vecPar vectorTM] naturalTM
1266 lengthTExpr = AST.ReturnSm (Just $ AST.PrimName (AST.NAttribute $
1267 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))
1268 shiftlSpec = AST.Function (mkVHDLExtId shiftlId) [AST.IfaceVarDec vecPar vectorTM,
1269 AST.IfaceVarDec aPar elemTM ] vectorTM
1270 -- variable res : fsvec_x (0 to vec'length-1);
1273 (AST.SubtypeIn vectorTM
1274 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1275 [AST.ToRange (AST.PrimLit "0")
1276 (AST.PrimName (AST.NAttribute $
1277 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1278 (AST.PrimLit "1")) ]))
1280 -- res := a & init(vec)
1281 shiftlExpr = AST.NSimple resId AST.:=
1282 (AST.PrimName (AST.NSimple aPar) AST.:&:
1283 (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId initId))
1284 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]))
1285 shiftlRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1286 shiftrSpec = AST.Function (mkVHDLExtId shiftrId) [AST.IfaceVarDec vecPar vectorTM,
1287 AST.IfaceVarDec aPar elemTM ] vectorTM
1288 -- variable res : fsvec_x (0 to vec'length-1);
1291 (AST.SubtypeIn vectorTM
1292 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1293 [AST.ToRange (AST.PrimLit "0")
1294 (AST.PrimName (AST.NAttribute $
1295 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1296 (AST.PrimLit "1")) ]))
1298 -- res := tail(vec) & a
1299 shiftrExpr = AST.NSimple resId AST.:=
1300 ((AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId tailId))
1301 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]) AST.:&:
1302 (AST.PrimName (AST.NSimple aPar)))
1304 shiftrRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1305 nullSpec = AST.Function (mkVHDLExtId nullId) [AST.IfaceVarDec vecPar vectorTM] booleanTM
1306 -- return vec'length = 0
1307 nullExpr = AST.ReturnSm (Just $
1308 AST.PrimName (AST.NAttribute $
1309 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:=:
1311 rotlSpec = AST.Function (mkVHDLExtId rotlId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
1312 -- variable res : fsvec_x (0 to vec'length-1);
1315 (AST.SubtypeIn vectorTM
1316 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1317 [AST.ToRange (AST.PrimLit "0")
1318 (AST.PrimName (AST.NAttribute $
1319 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1320 (AST.PrimLit "1")) ]))
1322 -- if null(vec) then res := vec else res := last(vec) & init(vec)
1323 rotlExpr = AST.IfSm (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId nullId))
1324 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)])
1325 [AST.NSimple resId AST.:= (AST.PrimName $ AST.NSimple vecPar)]
1327 (Just $ AST.Else [rotlExprRet])
1329 AST.NSimple resId AST.:=
1330 ((AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId lastId))
1331 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]) AST.:&:
1332 (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId initId))
1333 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]))
1334 rotlRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1335 rotrSpec = AST.Function (mkVHDLExtId rotrId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
1336 -- variable res : fsvec_x (0 to vec'length-1);
1339 (AST.SubtypeIn vectorTM
1340 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1341 [AST.ToRange (AST.PrimLit "0")
1342 (AST.PrimName (AST.NAttribute $
1343 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1344 (AST.PrimLit "1")) ]))
1346 -- if null(vec) then res := vec else res := tail(vec) & head(vec)
1347 rotrExpr = AST.IfSm (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId nullId))
1348 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)])
1349 [AST.NSimple resId AST.:= (AST.PrimName $ AST.NSimple vecPar)]
1351 (Just $ AST.Else [rotrExprRet])
1353 AST.NSimple resId AST.:=
1354 ((AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId tailId))
1355 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]) AST.:&:
1356 (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId headId))
1357 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]))
1358 rotrRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1359 reverseSpec = AST.Function (mkVHDLExtId reverseId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
1362 (AST.SubtypeIn vectorTM
1363 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1364 [AST.ToRange (AST.PrimLit "0")
1365 (AST.PrimName (AST.NAttribute $
1366 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1367 (AST.PrimLit "1")) ]))
1369 -- for i in 0 to res'range loop
1370 -- res(vec'length-i-1) := vec(i);
1373 AST.ForSM iId (AST.AttribRange $ AST.AttribName (AST.NSimple resId) (AST.NSimple $ rangeId) Nothing) [reverseAssign]
1374 -- res(vec'length-i-1) := vec(i);
1375 reverseAssign = AST.NIndexed (AST.IndexedName (AST.NSimple resId) [destExp]) AST.:=
1376 (AST.PrimName $ AST.NIndexed (AST.IndexedName (AST.NSimple vecPar)
1377 [AST.PrimName $ AST.NSimple iId]))
1378 where destExp = AST.PrimName (AST.NAttribute $ AST.AttribName (AST.NSimple vecPar)
1379 (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1380 AST.PrimName (AST.NSimple iId) AST.:-:
1383 reverseRet = AST.ReturnSm (Just $ AST.PrimName (AST.NSimple resId))
1386 -----------------------------------------------------------------------------
1387 -- A table of builtin functions
1388 -----------------------------------------------------------------------------
1390 -- A function that generates VHDL for a builtin function
1391 type BuiltinBuilder =
1392 (Either CoreSyn.CoreBndr AST.VHDLName) -- ^ The destination signal and it's original type
1393 -> CoreSyn.CoreBndr -- ^ The function called
1394 -> [Either CoreSyn.CoreExpr AST.Expr] -- ^ The value arguments passed (excluding type and
1395 -- dictionary arguments).
1396 -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
1397 -- ^ The corresponding VHDL concurrent statements and entities
1400 -- A map of a builtin function to VHDL function builder
1401 type NameTable = Map.Map String (Int, BuiltinBuilder )
1403 -- | The builtin functions we support. Maps a name to an argument count and a
1404 -- builder function.
1405 globalNameTable :: NameTable
1406 globalNameTable = Map.fromList
1407 [ (exId , (2, genFCall True ) )
1408 , (replaceId , (3, genFCall False ) )
1409 , (headId , (1, genFCall True ) )
1410 , (lastId , (1, genFCall True ) )
1411 , (tailId , (1, genFCall False ) )
1412 , (initId , (1, genFCall False ) )
1413 , (takeId , (2, genFCall False ) )
1414 , (dropId , (2, genFCall False ) )
1415 , (selId , (4, genFCall False ) )
1416 , (plusgtId , (2, genFCall False ) )
1417 , (ltplusId , (2, genFCall False ) )
1418 , (plusplusId , (2, genFCall False ) )
1419 , (mapId , (2, genMap ) )
1420 , (zipWithId , (3, genZipWith ) )
1421 , (foldlId , (3, genFoldl ) )
1422 , (foldrId , (3, genFoldr ) )
1423 , (zipId , (2, genZip ) )
1424 , (unzipId , (1, genUnzip ) )
1425 , (shiftlId , (2, genFCall False ) )
1426 , (shiftrId , (2, genFCall False ) )
1427 , (rotlId , (1, genFCall False ) )
1428 , (rotrId , (1, genFCall False ) )
1429 , (concatId , (1, genConcat ) )
1430 , (reverseId , (1, genFCall False ) )
1431 , (iteratenId , (3, genIteraten ) )
1432 , (iterateId , (2, genIterate ) )
1433 , (generatenId , (3, genGeneraten ) )
1434 , (generateId , (2, genGenerate ) )
1435 , (emptyId , (0, genFCall False ) )
1436 , (singletonId , (1, genFCall False ) )
1437 , (copynId , (2, genFCall False ) )
1438 , (copyId , (1, genCopy ) )
1439 , (lengthTId , (1, genFCall False ) )
1440 , (nullId , (1, genFCall False ) )
1441 , (hwxorId , (2, genOperator2 AST.Xor ) )
1442 , (hwandId , (2, genOperator2 AST.And ) )
1443 , (hworId , (2, genOperator2 AST.Or ) )
1444 , (hwnotId , (1, genOperator1 AST.Not ) )
1445 , (equalityId , (2, genOperator2 (AST.:=:) ) )
1446 , (inEqualityId , (2, genOperator2 (AST.:/=:) ) )
1447 , (boolOrId , (2, genOperator2 AST.Or ) )
1448 , (boolAndId , (2, genOperator2 AST.And ) )
1449 , (plusId , (2, genOperator2 (AST.:+:) ) )
1450 , (timesId , (2, genOperator2 (AST.:*:) ) )
1451 , (negateId , (1, genNegation ) )
1452 , (minusId , (2, genOperator2 (AST.:-:) ) )
1453 , (fromSizedWordId , (1, genFromSizedWord ) )
1454 , (fromIntegerId , (1, genFromInteger ) )
1455 , (resizeId , (1, genResize ) )
1456 , (sizedIntId , (1, genSizedInt ) )
1457 , (smallIntegerId , (1, genFromInteger ) )
1458 , (fstId , (1, genFst ) )
1459 , (sndId , (1, genSnd ) )
1460 , (blockRAMId , (5, genBlockRAM ) )
1461 --, (tfvecId , (1, genTFVec ) )
1462 , (minimumId , (2, error $ "\nFunction name: \"minimum\" is used internally, use another name"))